home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / lib / mathlib / libblas / test / zblat2.f < prev    next >
Encoding:
Text File  |  1994-08-02  |  113.4 KB  |  3,250 lines
  1.       PROGRAM ZBLAT2
  2. *
  3. *  Test program for the COMPLEX*16       Level 2 Blas.
  4. *
  5. *  The program must be driven by a short data file. The first 18 records
  6. *  of the file are read using list-directed input, the last 17 records
  7. *  are read using the format ( A6, L2 ). An annotated example of a data
  8. *  file can be obtained by deleting the first 3 characters from the
  9. *  following 35 lines:
  10. *  'ZBLAT2.SUMM'     NAME OF SUMMARY OUTPUT FILE
  11. *  6                 UNIT NUMBER OF SUMMARY FILE
  12. *  'CBLA2T.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
  13. *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
  14. *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
  15. *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
  16. *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
  17. *  16.0     THRESHOLD VALUE OF TEST RATIO
  18. *  6                 NUMBER OF VALUES OF N
  19. *  0 1 2 3 5 9       VALUES OF N
  20. *  4                 NUMBER OF VALUES OF K
  21. *  0 1 2 4           VALUES OF K
  22. *  4                 NUMBER OF VALUES OF INCX AND INCY
  23. *  1 2 -1 -2         VALUES OF INCX AND INCY
  24. *  3                 NUMBER OF VALUES OF ALPHA
  25. *  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA
  26. *  3                 NUMBER OF VALUES OF BETA
  27. *  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA
  28. *  ZGEMV  T PUT F FOR NO TEST. SAME COLUMNS.
  29. *  ZGBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  30. *  ZHEMV  T PUT F FOR NO TEST. SAME COLUMNS.
  31. *  ZHBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  32. *  ZHPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  33. *  ZTRMV  T PUT F FOR NO TEST. SAME COLUMNS.
  34. *  ZTBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  35. *  ZTPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  36. *  ZTRSV  T PUT F FOR NO TEST. SAME COLUMNS.
  37. *  ZTBSV  T PUT F FOR NO TEST. SAME COLUMNS.
  38. *  ZTPSV  T PUT F FOR NO TEST. SAME COLUMNS.
  39. *  ZGERC  T PUT F FOR NO TEST. SAME COLUMNS.
  40. *  ZGERU  T PUT F FOR NO TEST. SAME COLUMNS.
  41. *  ZHER   T PUT F FOR NO TEST. SAME COLUMNS.
  42. *  ZHPR   T PUT F FOR NO TEST. SAME COLUMNS.
  43. *  ZHER2  T PUT F FOR NO TEST. SAME COLUMNS.
  44. *  ZHPR2  T PUT F FOR NO TEST. SAME COLUMNS.
  45. *
  46. *     See:
  47. *
  48. *        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
  49. *        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
  50. *
  51. *        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
  52. *        and  Computer Science  Division,  Argonne  National Laboratory,
  53. *        9700 South Cass Avenue, Argonne, Illinois 60439, US.
  54. *
  55. *        Or
  56. *
  57. *        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
  58. *        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
  59. *        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
  60. *        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
  61. *
  62. *
  63. *  -- Written on 10-August-1987.
  64. *     Richard Hanson, Sandia National Labs.
  65. *     Jeremy Du Croz, NAG Central Office.
  66. *
  67. *     .. Parameters ..
  68.       INTEGER            NIN
  69.       PARAMETER          ( NIN = 5 )
  70.       INTEGER            NSUBS
  71.       PARAMETER          ( NSUBS = 17 )
  72.       COMPLEX*16         ZERO, ONE
  73.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  74.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  75.       DOUBLE PRECISION   RZERO, RHALF, RONE
  76.       PARAMETER          ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
  77.       INTEGER            NMAX, INCMAX
  78.       PARAMETER          ( NMAX = 65, INCMAX = 2 )
  79.       INTEGER            NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
  80.       PARAMETER          ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
  81.      $                   NALMAX = 7, NBEMAX = 7 )
  82. *     .. Local Scalars ..
  83.       DOUBLE PRECISION   EPS, ERR, THRESH
  84.       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
  85.      $                   NOUT, NTRA
  86.       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
  87.      $                   TSTERR
  88.       CHARACTER*1        TRANS
  89.       CHARACTER*6        SNAMET
  90.       CHARACTER*32       SNAPS, SUMMRY
  91. *     .. Local Arrays ..
  92.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ),
  93.      $                   ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
  94.      $                   X( NMAX ), XS( NMAX*INCMAX ),
  95.      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  96.      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  97.      $                   YY( NMAX*INCMAX ), Z( 2*NMAX )
  98.       DOUBLE PRECISION   G( NMAX )
  99.       INTEGER            IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
  100.       LOGICAL            LTEST( NSUBS )
  101.       CHARACTER*6        SNAMES( NSUBS )
  102. *     .. External Functions ..
  103.       DOUBLE PRECISION   DDIFF
  104.       LOGICAL            LZE
  105.       EXTERNAL           DDIFF, LZE
  106. *     .. External Subroutines ..
  107.       EXTERNAL           ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6,
  108.      $                   ZCHKE, ZMVCH
  109. *     .. Intrinsic Functions ..
  110.       INTRINSIC          ABS, MAX, MIN
  111. *     .. Scalars in Common ..
  112.       INTEGER            INFOT, NOUTC
  113.       LOGICAL            LERR, OK
  114.       CHARACTER*6        SRNAMT
  115. *     .. Common blocks ..
  116.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  117.       COMMON             /SRNAMC/SRNAMT
  118. *     .. Data statements ..
  119.       DATA               SNAMES/'ZGEMV ', 'ZGBMV ', 'ZHEMV ', 'ZHBMV ',
  120.      $                   'ZHPMV ', 'ZTRMV ', 'ZTBMV ', 'ZTPMV ',
  121.      $                   'ZTRSV ', 'ZTBSV ', 'ZTPSV ', 'ZGERC ',
  122.      $                   'ZGERU ', 'ZHER  ', 'ZHPR  ', 'ZHER2 ',
  123.      $                   'ZHPR2 '/
  124. *     .. Executable Statements ..
  125. *
  126. *     Read name and unit number for summary output file and open file.
  127. *
  128.       READ( NIN, FMT = * )SUMMRY
  129.       READ( NIN, FMT = * )NOUT
  130.       OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
  131.       NOUTC = NOUT
  132. *
  133. *     Read name and unit number for snapshot output file and open file.
  134. *
  135.       READ( NIN, FMT = * )SNAPS
  136.       READ( NIN, FMT = * )NTRA
  137.       TRACE = NTRA.GE.0
  138.       IF( TRACE )THEN
  139.          OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
  140.       END IF
  141. *     Read the flag that directs rewinding of the snapshot file.
  142.       READ( NIN, FMT = * )REWI
  143.       REWI = REWI.AND.TRACE
  144. *     Read the flag that directs stopping on any failure.
  145.       READ( NIN, FMT = * )SFATAL
  146. *     Read the flag that indicates whether error exits are to be tested.
  147.       READ( NIN, FMT = * )TSTERR
  148. *     Read the threshold value of the test ratio
  149.       READ( NIN, FMT = * )THRESH
  150. *
  151. *     Read and check the parameter values for the tests.
  152. *
  153. *     Values of N
  154.       READ( NIN, FMT = * )NIDIM
  155.       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
  156.          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
  157.          GO TO 230
  158.       END IF
  159.       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
  160.       DO 10 I = 1, NIDIM
  161.          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
  162.             WRITE( NOUT, FMT = 9996 )NMAX
  163.             GO TO 230
  164.          END IF
  165.    10 CONTINUE
  166. *     Values of K
  167.       READ( NIN, FMT = * )NKB
  168.       IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
  169.          WRITE( NOUT, FMT = 9997 )'K', NKBMAX
  170.          GO TO 230
  171.       END IF
  172.       READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
  173.       DO 20 I = 1, NKB
  174.          IF( KB( I ).LT.0 )THEN
  175.             WRITE( NOUT, FMT = 9995 )
  176.             GO TO 230
  177.          END IF
  178.    20 CONTINUE
  179. *     Values of INCX and INCY
  180.       READ( NIN, FMT = * )NINC
  181.       IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
  182.          WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
  183.          GO TO 230
  184.       END IF
  185.       READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
  186.       DO 30 I = 1, NINC
  187.          IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
  188.             WRITE( NOUT, FMT = 9994 )INCMAX
  189.             GO TO 230
  190.          END IF
  191.    30 CONTINUE
  192. *     Values of ALPHA
  193.       READ( NIN, FMT = * )NALF
  194.       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
  195.          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
  196.          GO TO 230
  197.       END IF
  198.       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
  199. *     Values of BETA
  200.       READ( NIN, FMT = * )NBET
  201.       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
  202.          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
  203.          GO TO 230
  204.       END IF
  205.       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
  206. *
  207. *     Report values of parameters.
  208. *
  209.       WRITE( NOUT, FMT = 9993 )
  210.       WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
  211.       WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
  212.       WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
  213.       WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
  214.       WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
  215.       IF( .NOT.TSTERR )THEN
  216.          WRITE( NOUT, FMT = * )
  217.          WRITE( NOUT, FMT = 9980 )
  218.       END IF
  219.       WRITE( NOUT, FMT = * )
  220.       WRITE( NOUT, FMT = 9999 )THRESH
  221.       WRITE( NOUT, FMT = * )
  222. *
  223. *     Read names of subroutines and flags which indicate
  224. *     whether they are to be tested.
  225. *
  226.       DO 40 I = 1, NSUBS
  227.          LTEST( I ) = .FALSE.
  228.    40 CONTINUE
  229.    50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
  230.       DO 60 I = 1, NSUBS
  231.          IF( SNAMET.EQ.SNAMES( I ) )
  232.      $      GO TO 70
  233.    60 CONTINUE
  234.       WRITE( NOUT, FMT = 9986 )SNAMET
  235.       STOP
  236.    70 LTEST( I ) = LTESTT
  237.       GO TO 50
  238. *
  239.    80 CONTINUE
  240.       CLOSE ( NIN )
  241. *
  242. *     Compute EPS (the machine precision).
  243. *
  244.       EPS = RONE
  245.    90 CONTINUE
  246.       IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
  247.      $   GO TO 100
  248.       EPS = RHALF*EPS
  249.       GO TO 90
  250.   100 CONTINUE
  251.       EPS = EPS + EPS
  252.       WRITE( NOUT, FMT = 9998 )EPS
  253. *
  254. *     Check the reliability of ZMVCH using exact data.
  255. *
  256.       N = MIN( 32, NMAX )
  257.       DO 120 J = 1, N
  258.          DO 110 I = 1, N
  259.             A( I, J ) = MAX( I - J + 1, 0 )
  260.   110    CONTINUE
  261.          X( J ) = J
  262.          Y( J ) = ZERO
  263.   120 CONTINUE
  264.       DO 130 J = 1, N
  265.          YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
  266.   130 CONTINUE
  267. *     YY holds the exact result. On exit from ZMVCH YT holds
  268. *     the result computed by ZMVCH.
  269.       TRANS = 'N'
  270.       CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
  271.      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
  272.       SAME = LZE( YY, YT, N )
  273.       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
  274.          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
  275.          STOP
  276.       END IF
  277.       TRANS = 'T'
  278.       CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
  279.      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
  280.       SAME = LZE( YY, YT, N )
  281.       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
  282.          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
  283.          STOP
  284.       END IF
  285. *
  286. *     Test each subroutine in turn.
  287. *
  288.       DO 210 ISNUM = 1, NSUBS
  289.          WRITE( NOUT, FMT = * )
  290.          IF( .NOT.LTEST( ISNUM ) )THEN
  291. *           Subprogram is not to be tested.
  292.             WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
  293.          ELSE
  294.             SRNAMT = SNAMES( ISNUM )
  295. *           Test error exits.
  296.             IF( TSTERR )THEN
  297.                CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
  298.                WRITE( NOUT, FMT = * )
  299.             END IF
  300. *           Test computations.
  301.             INFOT = 0
  302.             OK = .TRUE.
  303.             FATAL = .FALSE.
  304.             GO TO ( 140, 140, 150, 150, 150, 160, 160,
  305.      $              160, 160, 160, 160, 170, 170, 180,
  306.      $              180, 190, 190 )ISNUM
  307. *           Test ZGEMV, 01, and ZGBMV, 02.
  308.   140       CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  309.      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
  310.      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
  311.      $                  X, XX, XS, Y, YY, YS, YT, G )
  312.             GO TO 200
  313. *           Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05.
  314.   150       CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  315.      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
  316.      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
  317.      $                  X, XX, XS, Y, YY, YS, YT, G )
  318.             GO TO 200
  319. *           Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08,
  320. *           ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11.
  321.   160       CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  322.      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
  323.      $                  NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
  324.             GO TO 200
  325. *           Test ZGERC, 12, ZGERU, 13.
  326.   170       CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  327.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
  328.      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
  329.      $                  YT, G, Z )
  330.             GO TO 200
  331. *           Test ZHER, 14, and ZHPR, 15.
  332.   180       CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  333.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
  334.      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
  335.      $                  YT, G, Z )
  336.             GO TO 200
  337. *           Test ZHER2, 16, and ZHPR2, 17.
  338.   190       CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  339.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
  340.      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
  341.      $                  YT, G, Z )
  342. *
  343.   200       IF( FATAL.AND.SFATAL )
  344.      $         GO TO 220
  345.          END IF
  346.   210 CONTINUE
  347.       WRITE( NOUT, FMT = 9982 )
  348.       GO TO 240
  349. *
  350.   220 CONTINUE
  351.       WRITE( NOUT, FMT = 9981 )
  352.       GO TO 240
  353. *
  354.   230 CONTINUE
  355.       WRITE( NOUT, FMT = 9987 )
  356. *
  357.   240 CONTINUE
  358.       IF( TRACE )
  359.      $   CLOSE ( NTRA )
  360.       CLOSE ( NOUT )
  361.       STOP
  362. *
  363.  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
  364.      $      'S THAN', F8.2 )
  365.  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
  366.  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
  367.      $      'THAN ', I2 )
  368.  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
  369.  9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
  370.  9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
  371.      $      I2 )
  372.  9993 FORMAT( ' TESTS OF THE COMPLEX*16       LEVEL 2 BLAS', //' THE F',
  373.      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
  374.  9992 FORMAT( '   FOR N              ', 9I6 )
  375.  9991 FORMAT( '   FOR K              ', 7I6 )
  376.  9990 FORMAT( '   FOR INCX AND INCY  ', 7I6 )
  377.  9989 FORMAT( '   FOR ALPHA          ',
  378.      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
  379.  9988 FORMAT( '   FOR BETA           ',
  380.      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
  381.  9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
  382.      $      /' ******* TESTS ABANDONED *******' )
  383.  9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
  384.      $      'ESTS ABANDONED *******' )
  385.  9985 FORMAT( ' ERROR IN ZMVCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
  386.      $      'ATED WRONGLY.', /' ZMVCH WAS CALLED WITH TRANS = ', A1,
  387.      $      ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
  388.      $   ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
  389.      $      , /' ******* TESTS ABANDONED *******' )
  390.  9984 FORMAT( A6, L2 )
  391.  9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
  392.  9982 FORMAT( /' END OF TESTS' )
  393.  9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
  394.  9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
  395. *
  396. *     End of ZBLAT2.
  397. *
  398.       END
  399.       SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  400.      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
  401.      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
  402.      $                  XS, Y, YY, YS, YT, G )
  403. *
  404. *  Tests ZGEMV and ZGBMV.
  405. *
  406. *  Auxiliary routine for test program for Level 2 Blas.
  407. *
  408. *  -- Written on 10-August-1987.
  409. *     Richard Hanson, Sandia National Labs.
  410. *     Jeremy Du Croz, NAG Central Office.
  411. *
  412. *     .. Parameters ..
  413.       COMPLEX*16         ZERO, HALF
  414.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  415.      $                   HALF = ( 0.5D0, 0.0D0 ) )
  416.       DOUBLE PRECISION   RZERO
  417.       PARAMETER          ( RZERO = 0.0D0 )
  418. *     .. Scalar Arguments ..
  419.       DOUBLE PRECISION   EPS, THRESH
  420.       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
  421.      $                   NOUT, NTRA
  422.       LOGICAL            FATAL, REWI, TRACE
  423.       CHARACTER*6        SNAME
  424. *     .. Array Arguments ..
  425.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  426.      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
  427.      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
  428.      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
  429.      $                   YY( NMAX*INCMAX )
  430.       DOUBLE PRECISION   G( NMAX )
  431.       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
  432. *     .. Local Scalars ..
  433.       COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL
  434.       DOUBLE PRECISION   ERR, ERRMAX
  435.       INTEGER            I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
  436.      $                   INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
  437.      $                   LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
  438.      $                   NL, NS
  439.       LOGICAL            BANDED, FULL, NULL, RESET, SAME, TRAN
  440.       CHARACTER*1        TRANS, TRANSS
  441.       CHARACTER*3        ICH
  442. *     .. Local Arrays ..
  443.       LOGICAL            ISAME( 13 )
  444. *     .. External Functions ..
  445.       LOGICAL            LZE, LZERES
  446.       EXTERNAL           LZE, LZERES
  447. *     .. External Subroutines ..
  448.       EXTERNAL           ZGBMV, ZGEMV, ZMAKE, ZMVCH
  449. *     .. Intrinsic Functions ..
  450.       INTRINSIC          ABS, MAX, MIN
  451. *     .. Scalars in Common ..
  452.       INTEGER            INFOT, NOUTC
  453.       LOGICAL            LERR, OK
  454. *     .. Common blocks ..
  455.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  456. *     .. Data statements ..
  457.       DATA               ICH/'NTC'/
  458. *     .. Executable Statements ..
  459.       FULL = SNAME( 3: 3 ).EQ.'E'
  460.       BANDED = SNAME( 3: 3 ).EQ.'B'
  461. *     Define the number of arguments.
  462.       IF( FULL )THEN
  463.          NARGS = 11
  464.       ELSE IF( BANDED )THEN
  465.          NARGS = 13
  466.       END IF
  467. *
  468.       NC = 0
  469.       RESET = .TRUE.
  470.       ERRMAX = RZERO
  471. *
  472.       DO 120 IN = 1, NIDIM
  473.          N = IDIM( IN )
  474.          ND = N/2 + 1
  475. *
  476.          DO 110 IM = 1, 2
  477.             IF( IM.EQ.1 )
  478.      $         M = MAX( N - ND, 0 )
  479.             IF( IM.EQ.2 )
  480.      $         M = MIN( N + ND, NMAX )
  481. *
  482.             IF( BANDED )THEN
  483.                NK = NKB
  484.             ELSE
  485.                NK = 1
  486.             END IF
  487.             DO 100 IKU = 1, NK
  488.                IF( BANDED )THEN
  489.                   KU = KB( IKU )
  490.                   KL = MAX( KU - 1, 0 )
  491.                ELSE
  492.                   KU = N - 1
  493.                   KL = M - 1
  494.                END IF
  495. *              Set LDA to 1 more than minimum value if room.
  496.                IF( BANDED )THEN
  497.                   LDA = KL + KU + 1
  498.                ELSE
  499.                   LDA = M
  500.                END IF
  501.                IF( LDA.LT.NMAX )
  502.      $            LDA = LDA + 1
  503. *              Skip tests if not enough room.
  504.                IF( LDA.GT.NMAX )
  505.      $            GO TO 100
  506.                LAA = LDA*N
  507.                NULL = N.LE.0.OR.M.LE.0
  508. *
  509. *              Generate the matrix A.
  510. *
  511.                TRANSL = ZERO
  512.                CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
  513.      $                     LDA, KL, KU, RESET, TRANSL )
  514. *
  515.                DO 90 IC = 1, 3
  516.                   TRANS = ICH( IC: IC )
  517.                   TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
  518. *
  519.                   IF( TRAN )THEN
  520.                      ML = N
  521.                      NL = M
  522.                   ELSE
  523.                      ML = M
  524.                      NL = N
  525.                   END IF
  526. *
  527.                   DO 80 IX = 1, NINC
  528.                      INCX = INC( IX )
  529.                      LX = ABS( INCX )*NL
  530. *
  531. *                    Generate the vector X.
  532. *
  533.                      TRANSL = HALF
  534.                      CALL ZMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
  535.      $                           ABS( INCX ), 0, NL - 1, RESET, TRANSL )
  536.                      IF( NL.GT.1 )THEN
  537.                         X( NL/2 ) = ZERO
  538.                         XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
  539.                      END IF
  540. *
  541.                      DO 70 IY = 1, NINC
  542.                         INCY = INC( IY )
  543.                         LY = ABS( INCY )*ML
  544. *
  545.                         DO 60 IA = 1, NALF
  546.                            ALPHA = ALF( IA )
  547. *
  548.                            DO 50 IB = 1, NBET
  549.                               BETA = BET( IB )
  550. *
  551. *                             Generate the vector Y.
  552. *
  553.                               TRANSL = ZERO
  554.                               CALL ZMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
  555.      $                                    YY, ABS( INCY ), 0, ML - 1,
  556.      $                                    RESET, TRANSL )
  557. *
  558.                               NC = NC + 1
  559. *
  560. *                             Save every datum before calling the
  561. *                             subroutine.
  562. *
  563.                               TRANSS = TRANS
  564.                               MS = M
  565.                               NS = N
  566.                               KLS = KL
  567.                               KUS = KU
  568.                               ALS = ALPHA
  569.                               DO 10 I = 1, LAA
  570.                                  AS( I ) = AA( I )
  571.    10                         CONTINUE
  572.                               LDAS = LDA
  573.                               DO 20 I = 1, LX
  574.                                  XS( I ) = XX( I )
  575.    20                         CONTINUE
  576.                               INCXS = INCX
  577.                               BLS = BETA
  578.                               DO 30 I = 1, LY
  579.                                  YS( I ) = YY( I )
  580.    30                         CONTINUE
  581.                               INCYS = INCY
  582. *
  583. *                             Call the subroutine.
  584. *
  585.                               IF( FULL )THEN
  586.                                  IF( TRACE )
  587.      $                              WRITE( NTRA, FMT = 9994 )NC, SNAME,
  588.      $                              TRANS, M, N, ALPHA, LDA, INCX, BETA,
  589.      $                              INCY
  590.                                  IF( REWI )
  591.      $                              REWIND NTRA
  592.                                  CALL ZGEMV( TRANS, M, N, ALPHA, AA,
  593.      $                                       LDA, XX, INCX, BETA, YY,
  594.      $                                       INCY )
  595.                               ELSE IF( BANDED )THEN
  596.                                  IF( TRACE )
  597.      $                              WRITE( NTRA, FMT = 9995 )NC, SNAME,
  598.      $                              TRANS, M, N, KL, KU, ALPHA, LDA,
  599.      $                              INCX, BETA, INCY
  600.                                  IF( REWI )
  601.      $                              REWIND NTRA
  602.                                  CALL ZGBMV( TRANS, M, N, KL, KU, ALPHA,
  603.      $                                       AA, LDA, XX, INCX, BETA,
  604.      $                                       YY, INCY )
  605.                               END IF
  606. *
  607. *                             Check if error-exit was taken incorrectly.
  608. *
  609.                               IF( .NOT.OK )THEN
  610.                                  WRITE( NOUT, FMT = 9993 )
  611.                                  FATAL = .TRUE.
  612.                                  GO TO 130
  613.                               END IF
  614. *
  615. *                             See what data changed inside subroutines.
  616. *
  617.                               ISAME( 1 ) = TRANS.EQ.TRANSS
  618.                               ISAME( 2 ) = MS.EQ.M
  619.                               ISAME( 3 ) = NS.EQ.N
  620.                               IF( FULL )THEN
  621.                                  ISAME( 4 ) = ALS.EQ.ALPHA
  622.                                  ISAME( 5 ) = LZE( AS, AA, LAA )
  623.                                  ISAME( 6 ) = LDAS.EQ.LDA
  624.                                  ISAME( 7 ) = LZE( XS, XX, LX )
  625.                                  ISAME( 8 ) = INCXS.EQ.INCX
  626.                                  ISAME( 9 ) = BLS.EQ.BETA
  627.                                  IF( NULL )THEN
  628.                                     ISAME( 10 ) = LZE( YS, YY, LY )
  629.                                  ELSE
  630.                                     ISAME( 10 ) = LZERES( 'GE', ' ', 1,
  631.      $                                            ML, YS, YY,
  632.      $                                            ABS( INCY ) )
  633.                                  END IF
  634.                                  ISAME( 11 ) = INCYS.EQ.INCY
  635.                               ELSE IF( BANDED )THEN
  636.                                  ISAME( 4 ) = KLS.EQ.KL
  637.                                  ISAME( 5 ) = KUS.EQ.KU
  638.                                  ISAME( 6 ) = ALS.EQ.ALPHA
  639.                                  ISAME( 7 ) = LZE( AS, AA, LAA )
  640.                                  ISAME( 8 ) = LDAS.EQ.LDA
  641.                                  ISAME( 9 ) = LZE( XS, XX, LX )
  642.                                  ISAME( 10 ) = INCXS.EQ.INCX
  643.                                  ISAME( 11 ) = BLS.EQ.BETA
  644.                                  IF( NULL )THEN
  645.                                     ISAME( 12 ) = LZE( YS, YY, LY )
  646.                                  ELSE
  647.                                     ISAME( 12 ) = LZERES( 'GE', ' ', 1,
  648.      $                                            ML, YS, YY,
  649.      $                                            ABS( INCY ) )
  650.                                  END IF
  651.                                  ISAME( 13 ) = INCYS.EQ.INCY
  652.                               END IF
  653. *
  654. *                             If data was incorrectly changed, report
  655. *                             and return.
  656. *
  657.                               SAME = .TRUE.
  658.                               DO 40 I = 1, NARGS
  659.                                  SAME = SAME.AND.ISAME( I )
  660.                                  IF( .NOT.ISAME( I ) )
  661.      $                              WRITE( NOUT, FMT = 9998 )I
  662.    40                         CONTINUE
  663.                               IF( .NOT.SAME )THEN
  664.                                  FATAL = .TRUE.
  665.                                  GO TO 130
  666.                               END IF
  667. *
  668.                               IF( .NOT.NULL )THEN
  669. *
  670. *                                Check the result.
  671. *
  672.                                  CALL ZMVCH( TRANS, M, N, ALPHA, A,
  673.      $                                       NMAX, X, INCX, BETA, Y,
  674.      $                                       INCY, YT, G, YY, EPS, ERR,
  675.      $                                       FATAL, NOUT, .TRUE. )
  676.                                  ERRMAX = MAX( ERRMAX, ERR )
  677. *                                If got really bad answer, report and
  678. *                                return.
  679.                                  IF( FATAL )
  680.      $                              GO TO 130
  681.                               ELSE
  682. *                                Avoid repeating tests with M.le.0 or
  683. *                                N.le.0.
  684.                                  GO TO 110
  685.                               END IF
  686. *
  687.    50                      CONTINUE
  688. *
  689.    60                   CONTINUE
  690. *
  691.    70                CONTINUE
  692. *
  693.    80             CONTINUE
  694. *
  695.    90          CONTINUE
  696. *
  697.   100       CONTINUE
  698. *
  699.   110    CONTINUE
  700. *
  701.   120 CONTINUE
  702. *
  703. *     Report result.
  704. *
  705.       IF( ERRMAX.LT.THRESH )THEN
  706.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  707.       ELSE
  708.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  709.       END IF
  710.       GO TO 140
  711. *
  712.   130 CONTINUE
  713.       WRITE( NOUT, FMT = 9996 )SNAME
  714.       IF( FULL )THEN
  715.          WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
  716.      $      INCX, BETA, INCY
  717.       ELSE IF( BANDED )THEN
  718.          WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
  719.      $      ALPHA, LDA, INCX, BETA, INCY
  720.       END IF
  721. *
  722.   140 CONTINUE
  723.       RETURN
  724. *
  725.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  726.      $      'S)' )
  727.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  728.      $      'ANGED INCORRECTLY *******' )
  729.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  730.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  731.      $      ' - SUSPECT *******' )
  732.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  733.  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(',
  734.      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
  735.      $      F4.1, '), Y,', I2, ') .' )
  736.  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
  737.      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
  738.      $      F4.1, '), Y,', I2, ')         .' )
  739.  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  740.      $      '******' )
  741. *
  742. *     End of ZCHK1.
  743. *
  744.       END
  745.       SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  746.      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
  747.      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
  748.      $                  XS, Y, YY, YS, YT, G )
  749. *
  750. *  Tests ZHEMV, ZHBMV and ZHPMV.
  751. *
  752. *  Auxiliary routine for test program for Level 2 Blas.
  753. *
  754. *  -- Written on 10-August-1987.
  755. *     Richard Hanson, Sandia National Labs.
  756. *     Jeremy Du Croz, NAG Central Office.
  757. *
  758. *     .. Parameters ..
  759.       COMPLEX*16         ZERO, HALF
  760.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  761.      $                   HALF = ( 0.5D0, 0.0D0 ) )
  762.       DOUBLE PRECISION   RZERO
  763.       PARAMETER          ( RZERO = 0.0D0 )
  764. *     .. Scalar Arguments ..
  765.       DOUBLE PRECISION   EPS, THRESH
  766.       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
  767.      $                   NOUT, NTRA
  768.       LOGICAL            FATAL, REWI, TRACE
  769.       CHARACTER*6        SNAME
  770. *     .. Array Arguments ..
  771.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  772.      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
  773.      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
  774.      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
  775.      $                   YY( NMAX*INCMAX )
  776.       DOUBLE PRECISION   G( NMAX )
  777.       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
  778. *     .. Local Scalars ..
  779.       COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL
  780.       DOUBLE PRECISION   ERR, ERRMAX
  781.       INTEGER            I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
  782.      $                   INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
  783.      $                   N, NARGS, NC, NK, NS
  784.       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
  785.       CHARACTER*1        UPLO, UPLOS
  786.       CHARACTER*2        ICH
  787. *     .. Local Arrays ..
  788.       LOGICAL            ISAME( 13 )
  789. *     .. External Functions ..
  790.       LOGICAL            LZE, LZERES
  791.       EXTERNAL           LZE, LZERES
  792. *     .. External Subroutines ..
  793.       EXTERNAL           ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH
  794. *     .. Intrinsic Functions ..
  795.       INTRINSIC          ABS, MAX
  796. *     .. Scalars in Common ..
  797.       INTEGER            INFOT, NOUTC
  798.       LOGICAL            LERR, OK
  799. *     .. Common blocks ..
  800.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  801. *     .. Data statements ..
  802.       DATA               ICH/'UL'/
  803. *     .. Executable Statements ..
  804.       FULL = SNAME( 3: 3 ).EQ.'E'
  805.       BANDED = SNAME( 3: 3 ).EQ.'B'
  806.       PACKED = SNAME( 3: 3 ).EQ.'P'
  807. *     Define the number of arguments.
  808.       IF( FULL )THEN
  809.          NARGS = 10
  810.       ELSE IF( BANDED )THEN
  811.          NARGS = 11
  812.       ELSE IF( PACKED )THEN
  813.          NARGS = 9
  814.       END IF
  815. *
  816.       NC = 0
  817.       RESET = .TRUE.
  818.       ERRMAX = RZERO
  819. *
  820.       DO 110 IN = 1, NIDIM
  821.          N = IDIM( IN )
  822. *
  823.          IF( BANDED )THEN
  824.             NK = NKB
  825.          ELSE
  826.             NK = 1
  827.          END IF
  828.          DO 100 IK = 1, NK
  829.             IF( BANDED )THEN
  830.                K = KB( IK )
  831.             ELSE
  832.                K = N - 1
  833.             END IF
  834. *           Set LDA to 1 more than minimum value if room.
  835.             IF( BANDED )THEN
  836.                LDA = K + 1
  837.             ELSE
  838.                LDA = N
  839.             END IF
  840.             IF( LDA.LT.NMAX )
  841.      $         LDA = LDA + 1
  842. *           Skip tests if not enough room.
  843.             IF( LDA.GT.NMAX )
  844.      $         GO TO 100
  845.             IF( PACKED )THEN
  846.                LAA = ( N*( N + 1 ) )/2
  847.             ELSE
  848.                LAA = LDA*N
  849.             END IF
  850.             NULL = N.LE.0
  851. *
  852.             DO 90 IC = 1, 2
  853.                UPLO = ICH( IC: IC )
  854. *
  855. *              Generate the matrix A.
  856. *
  857.                TRANSL = ZERO
  858.                CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
  859.      $                     LDA, K, K, RESET, TRANSL )
  860. *
  861.                DO 80 IX = 1, NINC
  862.                   INCX = INC( IX )
  863.                   LX = ABS( INCX )*N
  864. *
  865. *                 Generate the vector X.
  866. *
  867.                   TRANSL = HALF
  868.                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
  869.      $                        ABS( INCX ), 0, N - 1, RESET, TRANSL )
  870.                   IF( N.GT.1 )THEN
  871.                      X( N/2 ) = ZERO
  872.                      XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
  873.                   END IF
  874. *
  875.                   DO 70 IY = 1, NINC
  876.                      INCY = INC( IY )
  877.                      LY = ABS( INCY )*N
  878. *
  879.                      DO 60 IA = 1, NALF
  880.                         ALPHA = ALF( IA )
  881. *
  882.                         DO 50 IB = 1, NBET
  883.                            BETA = BET( IB )
  884. *
  885. *                          Generate the vector Y.
  886. *
  887.                            TRANSL = ZERO
  888.                            CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
  889.      $                                 ABS( INCY ), 0, N - 1, RESET,
  890.      $                                 TRANSL )
  891. *
  892.                            NC = NC + 1
  893. *
  894. *                          Save every datum before calling the
  895. *                          subroutine.
  896. *
  897.                            UPLOS = UPLO
  898.                            NS = N
  899.                            KS = K
  900.                            ALS = ALPHA
  901.                            DO 10 I = 1, LAA
  902.                               AS( I ) = AA( I )
  903.    10                      CONTINUE
  904.                            LDAS = LDA
  905.                            DO 20 I = 1, LX
  906.                               XS( I ) = XX( I )
  907.    20                      CONTINUE
  908.                            INCXS = INCX
  909.                            BLS = BETA
  910.                            DO 30 I = 1, LY
  911.                               YS( I ) = YY( I )
  912.    30                      CONTINUE
  913.                            INCYS = INCY
  914. *
  915. *                          Call the subroutine.
  916. *
  917.                            IF( FULL )THEN
  918.                               IF( TRACE )
  919.      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
  920.      $                           UPLO, N, ALPHA, LDA, INCX, BETA, INCY
  921.                               IF( REWI )
  922.      $                           REWIND NTRA
  923.                               CALL ZHEMV( UPLO, N, ALPHA, AA, LDA, XX,
  924.      $                                    INCX, BETA, YY, INCY )
  925.                            ELSE IF( BANDED )THEN
  926.                               IF( TRACE )
  927.      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
  928.      $                           UPLO, N, K, ALPHA, LDA, INCX, BETA,
  929.      $                           INCY
  930.                               IF( REWI )
  931.      $                           REWIND NTRA
  932.                               CALL ZHBMV( UPLO, N, K, ALPHA, AA, LDA,
  933.      $                                    XX, INCX, BETA, YY, INCY )
  934.                            ELSE IF( PACKED )THEN
  935.                               IF( TRACE )
  936.      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
  937.      $                           UPLO, N, ALPHA, INCX, BETA, INCY
  938.                               IF( REWI )
  939.      $                           REWIND NTRA
  940.                               CALL ZHPMV( UPLO, N, ALPHA, AA, XX, INCX,
  941.      $                                    BETA, YY, INCY )
  942.                            END IF
  943. *
  944. *                          Check if error-exit was taken incorrectly.
  945. *
  946.                            IF( .NOT.OK )THEN
  947.                               WRITE( NOUT, FMT = 9992 )
  948.                               FATAL = .TRUE.
  949.                               GO TO 120
  950.                            END IF
  951. *
  952. *                          See what data changed inside subroutines.
  953. *
  954.                            ISAME( 1 ) = UPLO.EQ.UPLOS
  955.                            ISAME( 2 ) = NS.EQ.N
  956.                            IF( FULL )THEN
  957.                               ISAME( 3 ) = ALS.EQ.ALPHA
  958.                               ISAME( 4 ) = LZE( AS, AA, LAA )
  959.                               ISAME( 5 ) = LDAS.EQ.LDA
  960.                               ISAME( 6 ) = LZE( XS, XX, LX )
  961.                               ISAME( 7 ) = INCXS.EQ.INCX
  962.                               ISAME( 8 ) = BLS.EQ.BETA
  963.                               IF( NULL )THEN
  964.                                  ISAME( 9 ) = LZE( YS, YY, LY )
  965.                               ELSE
  966.                                  ISAME( 9 ) = LZERES( 'GE', ' ', 1, N,
  967.      $                                        YS, YY, ABS( INCY ) )
  968.                               END IF
  969.                               ISAME( 10 ) = INCYS.EQ.INCY
  970.                            ELSE IF( BANDED )THEN
  971.                               ISAME( 3 ) = KS.EQ.K
  972.                               ISAME( 4 ) = ALS.EQ.ALPHA
  973.                               ISAME( 5 ) = LZE( AS, AA, LAA )
  974.                               ISAME( 6 ) = LDAS.EQ.LDA
  975.                               ISAME( 7 ) = LZE( XS, XX, LX )
  976.                               ISAME( 8 ) = INCXS.EQ.INCX
  977.                               ISAME( 9 ) = BLS.EQ.BETA
  978.                               IF( NULL )THEN
  979.                                  ISAME( 10 ) = LZE( YS, YY, LY )
  980.                               ELSE
  981.                                  ISAME( 10 ) = LZERES( 'GE', ' ', 1, N,
  982.      $                                         YS, YY, ABS( INCY ) )
  983.                               END IF
  984.                               ISAME( 11 ) = INCYS.EQ.INCY
  985.                            ELSE IF( PACKED )THEN
  986.                               ISAME( 3 ) = ALS.EQ.ALPHA
  987.                               ISAME( 4 ) = LZE( AS, AA, LAA )
  988.                               ISAME( 5 ) = LZE( XS, XX, LX )
  989.                               ISAME( 6 ) = INCXS.EQ.INCX
  990.                               ISAME( 7 ) = BLS.EQ.BETA
  991.                               IF( NULL )THEN
  992.                                  ISAME( 8 ) = LZE( YS, YY, LY )
  993.                               ELSE
  994.                                  ISAME( 8 ) = LZERES( 'GE', ' ', 1, N,
  995.      $                                        YS, YY, ABS( INCY ) )
  996.                               END IF
  997.                               ISAME( 9 ) = INCYS.EQ.INCY
  998.                            END IF
  999. *
  1000. *                          If data was incorrectly changed, report and
  1001. *                          return.
  1002. *
  1003.                            SAME = .TRUE.
  1004.                            DO 40 I = 1, NARGS
  1005.                               SAME = SAME.AND.ISAME( I )
  1006.                               IF( .NOT.ISAME( I ) )
  1007.      $                           WRITE( NOUT, FMT = 9998 )I
  1008.    40                      CONTINUE
  1009.                            IF( .NOT.SAME )THEN
  1010.                               FATAL = .TRUE.
  1011.                               GO TO 120
  1012.                            END IF
  1013. *
  1014.                            IF( .NOT.NULL )THEN
  1015. *
  1016. *                             Check the result.
  1017. *
  1018.                               CALL ZMVCH( 'N', N, N, ALPHA, A, NMAX, X,
  1019.      $                                    INCX, BETA, Y, INCY, YT, G,
  1020.      $                                    YY, EPS, ERR, FATAL, NOUT,
  1021.      $                                    .TRUE. )
  1022.                               ERRMAX = MAX( ERRMAX, ERR )
  1023. *                             If got really bad answer, report and
  1024. *                             return.
  1025.                               IF( FATAL )
  1026.      $                           GO TO 120
  1027.                            ELSE
  1028. *                             Avoid repeating tests with N.le.0
  1029.                               GO TO 110
  1030.                            END IF
  1031. *
  1032.    50                   CONTINUE
  1033. *
  1034.    60                CONTINUE
  1035. *
  1036.    70             CONTINUE
  1037. *
  1038.    80          CONTINUE
  1039. *
  1040.    90       CONTINUE
  1041. *
  1042.   100    CONTINUE
  1043. *
  1044.   110 CONTINUE
  1045. *
  1046. *     Report result.
  1047. *
  1048.       IF( ERRMAX.LT.THRESH )THEN
  1049.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1050.       ELSE
  1051.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1052.       END IF
  1053.       GO TO 130
  1054. *
  1055.   120 CONTINUE
  1056.       WRITE( NOUT, FMT = 9996 )SNAME
  1057.       IF( FULL )THEN
  1058.          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
  1059.      $      BETA, INCY
  1060.       ELSE IF( BANDED )THEN
  1061.          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
  1062.      $      INCX, BETA, INCY
  1063.       ELSE IF( PACKED )THEN
  1064.          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
  1065.      $      BETA, INCY
  1066.       END IF
  1067. *
  1068.   130 CONTINUE
  1069.       RETURN
  1070. *
  1071.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1072.      $      'S)' )
  1073.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1074.      $      'ANGED INCORRECTLY *******' )
  1075.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1076.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1077.      $      ' - SUSPECT *******' )
  1078.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1079.  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
  1080.      $      F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2,
  1081.      $      ')                .' )
  1082.  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
  1083.      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
  1084.      $      F4.1, '), Y,', I2, ')         .' )
  1085.  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
  1086.      $      F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ',
  1087.      $      'Y,', I2, ')             .' )
  1088.  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1089.      $      '******' )
  1090. *
  1091. *     End of ZCHK2.
  1092. *
  1093.       END
  1094.       SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  1095.      $                  FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
  1096.      $                  INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
  1097. *
  1098. *  Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV.
  1099. *
  1100. *  Auxiliary routine for test program for Level 2 Blas.
  1101. *
  1102. *  -- Written on 10-August-1987.
  1103. *     Richard Hanson, Sandia National Labs.
  1104. *     Jeremy Du Croz, NAG Central Office.
  1105. *
  1106. *     .. Parameters ..
  1107.       COMPLEX*16         ZERO, HALF, ONE
  1108.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  1109.      $                   HALF = ( 0.5D0, 0.0D0 ),
  1110.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  1111.       DOUBLE PRECISION   RZERO
  1112.       PARAMETER          ( RZERO = 0.0D0 )
  1113. *     .. Scalar Arguments ..
  1114.       DOUBLE PRECISION   EPS, THRESH
  1115.       INTEGER            INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
  1116.       LOGICAL            FATAL, REWI, TRACE
  1117.       CHARACTER*6        SNAME
  1118. *     .. Array Arguments ..
  1119.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ),
  1120.      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
  1121.      $                   XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
  1122.       DOUBLE PRECISION   G( NMAX )
  1123.       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
  1124. *     .. Local Scalars ..
  1125.       COMPLEX*16         TRANSL
  1126.       DOUBLE PRECISION   ERR, ERRMAX
  1127.       INTEGER            I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
  1128.      $                   KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
  1129.       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
  1130.       CHARACTER*1        DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
  1131.       CHARACTER*2        ICHD, ICHU
  1132.       CHARACTER*3        ICHT
  1133. *     .. Local Arrays ..
  1134.       LOGICAL            ISAME( 13 )
  1135. *     .. External Functions ..
  1136.       LOGICAL            LZE, LZERES
  1137.       EXTERNAL           LZE, LZERES
  1138. *     .. External Subroutines ..
  1139.       EXTERNAL           ZMAKE, ZMVCH, ZTBMV, ZTBSV, ZTPMV, ZTPSV,
  1140.      $                   ZTRMV, ZTRSV
  1141. *     .. Intrinsic Functions ..
  1142.       INTRINSIC          ABS, MAX
  1143. *     .. Scalars in Common ..
  1144.       INTEGER            INFOT, NOUTC
  1145.       LOGICAL            LERR, OK
  1146. *     .. Common blocks ..
  1147.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1148. *     .. Data statements ..
  1149.       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
  1150. *     .. Executable Statements ..
  1151.       FULL = SNAME( 3: 3 ).EQ.'R'
  1152.       BANDED = SNAME( 3: 3 ).EQ.'B'
  1153.       PACKED = SNAME( 3: 3 ).EQ.'P'
  1154. *     Define the number of arguments.
  1155.       IF( FULL )THEN
  1156.          NARGS = 8
  1157.       ELSE IF( BANDED )THEN
  1158.          NARGS = 9
  1159.       ELSE IF( PACKED )THEN
  1160.          NARGS = 7
  1161.       END IF
  1162. *
  1163.       NC = 0
  1164.       RESET = .TRUE.
  1165.       ERRMAX = RZERO
  1166. *     Set up zero vector for ZMVCH.
  1167.       DO 10 I = 1, NMAX
  1168.          Z( I ) = ZERO
  1169.    10 CONTINUE
  1170. *
  1171.       DO 110 IN = 1, NIDIM
  1172.          N = IDIM( IN )
  1173. *
  1174.          IF( BANDED )THEN
  1175.             NK = NKB
  1176.          ELSE
  1177.             NK = 1
  1178.          END IF
  1179.          DO 100 IK = 1, NK
  1180.             IF( BANDED )THEN
  1181.                K = KB( IK )
  1182.             ELSE
  1183.                K = N - 1
  1184.             END IF
  1185. *           Set LDA to 1 more than minimum value if room.
  1186.             IF( BANDED )THEN
  1187.                LDA = K + 1
  1188.             ELSE
  1189.                LDA = N
  1190.             END IF
  1191.             IF( LDA.LT.NMAX )
  1192.      $         LDA = LDA + 1
  1193. *           Skip tests if not enough room.
  1194.             IF( LDA.GT.NMAX )
  1195.      $         GO TO 100
  1196.             IF( PACKED )THEN
  1197.                LAA = ( N*( N + 1 ) )/2
  1198.             ELSE
  1199.                LAA = LDA*N
  1200.             END IF
  1201.             NULL = N.LE.0
  1202. *
  1203.             DO 90 ICU = 1, 2
  1204.                UPLO = ICHU( ICU: ICU )
  1205. *
  1206.                DO 80 ICT = 1, 3
  1207.                   TRANS = ICHT( ICT: ICT )
  1208. *
  1209.                   DO 70 ICD = 1, 2
  1210.                      DIAG = ICHD( ICD: ICD )
  1211. *
  1212. *                    Generate the matrix A.
  1213. *
  1214.                      TRANSL = ZERO
  1215.                      CALL ZMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
  1216.      $                           NMAX, AA, LDA, K, K, RESET, TRANSL )
  1217. *
  1218.                      DO 60 IX = 1, NINC
  1219.                         INCX = INC( IX )
  1220.                         LX = ABS( INCX )*N
  1221. *
  1222. *                       Generate the vector X.
  1223. *
  1224.                         TRANSL = HALF
  1225.                         CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
  1226.      $                              ABS( INCX ), 0, N - 1, RESET,
  1227.      $                              TRANSL )
  1228.                         IF( N.GT.1 )THEN
  1229.                            X( N/2 ) = ZERO
  1230.                            XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
  1231.                         END IF
  1232. *
  1233.                         NC = NC + 1
  1234. *
  1235. *                       Save every datum before calling the subroutine.
  1236. *
  1237.                         UPLOS = UPLO
  1238.                         TRANSS = TRANS
  1239.                         DIAGS = DIAG
  1240.                         NS = N
  1241.                         KS = K
  1242.                         DO 20 I = 1, LAA
  1243.                            AS( I ) = AA( I )
  1244.    20                   CONTINUE
  1245.                         LDAS = LDA
  1246.                         DO 30 I = 1, LX
  1247.                            XS( I ) = XX( I )
  1248.    30                   CONTINUE
  1249.                         INCXS = INCX
  1250. *
  1251. *                       Call the subroutine.
  1252. *
  1253.                         IF( SNAME( 4: 5 ).EQ.'MV' )THEN
  1254.                            IF( FULL )THEN
  1255.                               IF( TRACE )
  1256.      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
  1257.      $                           UPLO, TRANS, DIAG, N, LDA, INCX
  1258.                               IF( REWI )
  1259.      $                           REWIND NTRA
  1260.                               CALL ZTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
  1261.      $                                    XX, INCX )
  1262.                            ELSE IF( BANDED )THEN
  1263.                               IF( TRACE )
  1264.      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
  1265.      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
  1266.                               IF( REWI )
  1267.      $                           REWIND NTRA
  1268.                               CALL ZTBMV( UPLO, TRANS, DIAG, N, K, AA,
  1269.      $                                    LDA, XX, INCX )
  1270.                            ELSE IF( PACKED )THEN
  1271.                               IF( TRACE )
  1272.      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
  1273.      $                           UPLO, TRANS, DIAG, N, INCX
  1274.                               IF( REWI )
  1275.      $                           REWIND NTRA
  1276.                               CALL ZTPMV( UPLO, TRANS, DIAG, N, AA, XX,
  1277.      $                                    INCX )
  1278.                            END IF
  1279.                         ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
  1280.                            IF( FULL )THEN
  1281.                               IF( TRACE )
  1282.      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
  1283.      $                           UPLO, TRANS, DIAG, N, LDA, INCX
  1284.                               IF( REWI )
  1285.      $                           REWIND NTRA
  1286.                               CALL ZTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
  1287.      $                                    XX, INCX )
  1288.                            ELSE IF( BANDED )THEN
  1289.                               IF( TRACE )
  1290.      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
  1291.      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
  1292.                               IF( REWI )
  1293.      $                           REWIND NTRA
  1294.                               CALL ZTBSV( UPLO, TRANS, DIAG, N, K, AA,
  1295.      $                                    LDA, XX, INCX )
  1296.                            ELSE IF( PACKED )THEN
  1297.                               IF( TRACE )
  1298.      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
  1299.      $                           UPLO, TRANS, DIAG, N, INCX
  1300.                               IF( REWI )
  1301.      $                           REWIND NTRA
  1302.                               CALL ZTPSV( UPLO, TRANS, DIAG, N, AA, XX,
  1303.      $                                    INCX )
  1304.                            END IF
  1305.                         END IF
  1306. *
  1307. *                       Check if error-exit was taken incorrectly.
  1308. *
  1309.                         IF( .NOT.OK )THEN
  1310.                            WRITE( NOUT, FMT = 9992 )
  1311.                            FATAL = .TRUE.
  1312.                            GO TO 120
  1313.                         END IF
  1314. *
  1315. *                       See what data changed inside subroutines.
  1316. *
  1317.                         ISAME( 1 ) = UPLO.EQ.UPLOS
  1318.                         ISAME( 2 ) = TRANS.EQ.TRANSS
  1319.                         ISAME( 3 ) = DIAG.EQ.DIAGS
  1320.                         ISAME( 4 ) = NS.EQ.N
  1321.                         IF( FULL )THEN
  1322.                            ISAME( 5 ) = LZE( AS, AA, LAA )
  1323.                            ISAME( 6 ) = LDAS.EQ.LDA
  1324.                            IF( NULL )THEN
  1325.                               ISAME( 7 ) = LZE( XS, XX, LX )
  1326.                            ELSE
  1327.                               ISAME( 7 ) = LZERES( 'GE', ' ', 1, N, XS,
  1328.      $                                     XX, ABS( INCX ) )
  1329.                            END IF
  1330.                            ISAME( 8 ) = INCXS.EQ.INCX
  1331.                         ELSE IF( BANDED )THEN
  1332.                            ISAME( 5 ) = KS.EQ.K
  1333.                            ISAME( 6 ) = LZE( AS, AA, LAA )
  1334.                            ISAME( 7 ) = LDAS.EQ.LDA
  1335.                            IF( NULL )THEN
  1336.                               ISAME( 8 ) = LZE( XS, XX, LX )
  1337.                            ELSE
  1338.                               ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, XS,
  1339.      $                                     XX, ABS( INCX ) )
  1340.                            END IF
  1341.                            ISAME( 9 ) = INCXS.EQ.INCX
  1342.                         ELSE IF( PACKED )THEN
  1343.                            ISAME( 5 ) = LZE( AS, AA, LAA )
  1344.                            IF( NULL )THEN
  1345.                               ISAME( 6 ) = LZE( XS, XX, LX )
  1346.                            ELSE
  1347.                               ISAME( 6 ) = LZERES( 'GE', ' ', 1, N, XS,
  1348.      $                                     XX, ABS( INCX ) )
  1349.                            END IF
  1350.                            ISAME( 7 ) = INCXS.EQ.INCX
  1351.                         END IF
  1352. *
  1353. *                       If data was incorrectly changed, report and
  1354. *                       return.
  1355. *
  1356.                         SAME = .TRUE.
  1357.                         DO 40 I = 1, NARGS
  1358.                            SAME = SAME.AND.ISAME( I )
  1359.                            IF( .NOT.ISAME( I ) )
  1360.      $                        WRITE( NOUT, FMT = 9998 )I
  1361.    40                   CONTINUE
  1362.                         IF( .NOT.SAME )THEN
  1363.                            FATAL = .TRUE.
  1364.                            GO TO 120
  1365.                         END IF
  1366. *
  1367.                         IF( .NOT.NULL )THEN
  1368.                            IF( SNAME( 4: 5 ).EQ.'MV' )THEN
  1369. *
  1370. *                             Check the result.
  1371. *
  1372.                               CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X,
  1373.      $                                    INCX, ZERO, Z, INCX, XT, G,
  1374.      $                                    XX, EPS, ERR, FATAL, NOUT,
  1375.      $                                    .TRUE. )
  1376.                            ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
  1377. *
  1378. *                             Compute approximation to original vector.
  1379. *
  1380.                               DO 50 I = 1, N
  1381.                                  Z( I ) = XX( 1 + ( I - 1 )*
  1382.      $                                    ABS( INCX ) )
  1383.                                  XX( 1 + ( I - 1 )*ABS( INCX ) )
  1384.      $                              = X( I )
  1385.    50                         CONTINUE
  1386.                               CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, Z,
  1387.      $                                    INCX, ZERO, X, INCX, XT, G,
  1388.      $                                    XX, EPS, ERR, FATAL, NOUT,
  1389.      $                                    .FALSE. )
  1390.                            END IF
  1391.                            ERRMAX = MAX( ERRMAX, ERR )
  1392. *                          If got really bad answer, report and return.
  1393.                            IF( FATAL )
  1394.      $                        GO TO 120
  1395.                         ELSE
  1396. *                          Avoid repeating tests with N.le.0.
  1397.                            GO TO 110
  1398.                         END IF
  1399. *
  1400.    60                CONTINUE
  1401. *
  1402.    70             CONTINUE
  1403. *
  1404.    80          CONTINUE
  1405. *
  1406.    90       CONTINUE
  1407. *
  1408.   100    CONTINUE
  1409. *
  1410.   110 CONTINUE
  1411. *
  1412. *     Report result.
  1413. *
  1414.       IF( ERRMAX.LT.THRESH )THEN
  1415.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1416.       ELSE
  1417.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1418.       END IF
  1419.       GO TO 130
  1420. *
  1421.   120 CONTINUE
  1422.       WRITE( NOUT, FMT = 9996 )SNAME
  1423.       IF( FULL )THEN
  1424.          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
  1425.      $      INCX
  1426.       ELSE IF( BANDED )THEN
  1427.          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
  1428.      $      LDA, INCX
  1429.       ELSE IF( PACKED )THEN
  1430.          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
  1431.       END IF
  1432. *
  1433.   130 CONTINUE
  1434.       RETURN
  1435. *
  1436.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1437.      $      'S)' )
  1438.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1439.      $      'ANGED INCORRECTLY *******' )
  1440.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1441.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1442.      $      ' - SUSPECT *******' )
  1443.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1444.  9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
  1445.      $      'X,', I2, ')                                      .' )
  1446.  9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
  1447.      $      ' A,', I3, ', X,', I2, ')                               .' )
  1448.  9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
  1449.      $      I3, ', X,', I2, ')                                   .' )
  1450.  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1451.      $      '******' )
  1452. *
  1453. *     End of ZCHK3.
  1454. *
  1455.       END
  1456.       SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  1457.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
  1458.      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
  1459.      $                  Z )
  1460. *
  1461. *  Tests ZGERC and ZGERU.
  1462. *
  1463. *  Auxiliary routine for test program for Level 2 Blas.
  1464. *
  1465. *  -- Written on 10-August-1987.
  1466. *     Richard Hanson, Sandia National Labs.
  1467. *     Jeremy Du Croz, NAG Central Office.
  1468. *
  1469. *     .. Parameters ..
  1470.       COMPLEX*16         ZERO, HALF, ONE
  1471.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  1472.      $                   HALF = ( 0.5D0, 0.0D0 ),
  1473.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  1474.       DOUBLE PRECISION   RZERO
  1475.       PARAMETER          ( RZERO = 0.0D0 )
  1476. *     .. Scalar Arguments ..
  1477.       DOUBLE PRECISION   EPS, THRESH
  1478.       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
  1479.       LOGICAL            FATAL, REWI, TRACE
  1480.       CHARACTER*6        SNAME
  1481. *     .. Array Arguments ..
  1482.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  1483.      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
  1484.      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  1485.      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  1486.      $                   YY( NMAX*INCMAX ), Z( NMAX )
  1487.       DOUBLE PRECISION   G( NMAX )
  1488.       INTEGER            IDIM( NIDIM ), INC( NINC )
  1489. *     .. Local Scalars ..
  1490.       COMPLEX*16         ALPHA, ALS, TRANSL
  1491.       DOUBLE PRECISION   ERR, ERRMAX
  1492.       INTEGER            I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
  1493.      $                   IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
  1494.      $                   NC, ND, NS
  1495.       LOGICAL            CONJ, NULL, RESET, SAME
  1496. *     .. Local Arrays ..
  1497.       COMPLEX*16         W( 1 )
  1498.       LOGICAL            ISAME( 13 )
  1499. *     .. External Functions ..
  1500.       LOGICAL            LZE, LZERES
  1501.       EXTERNAL           LZE, LZERES
  1502. *     .. External Subroutines ..
  1503.       EXTERNAL           ZGERC, ZGERU, ZMAKE, ZMVCH
  1504. *     .. Intrinsic Functions ..
  1505.       INTRINSIC          ABS, DCONJG, MAX, MIN
  1506. *     .. Scalars in Common ..
  1507.       INTEGER            INFOT, NOUTC
  1508.       LOGICAL            LERR, OK
  1509. *     .. Common blocks ..
  1510.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1511. *     .. Executable Statements ..
  1512.       CONJ = SNAME( 5: 5 ).EQ.'C'
  1513. *     Define the number of arguments.
  1514.       NARGS = 9
  1515. *
  1516.       NC = 0
  1517.       RESET = .TRUE.
  1518.       ERRMAX = RZERO
  1519. *
  1520.       DO 120 IN = 1, NIDIM
  1521.          N = IDIM( IN )
  1522.          ND = N/2 + 1
  1523. *
  1524.          DO 110 IM = 1, 2
  1525.             IF( IM.EQ.1 )
  1526.      $         M = MAX( N - ND, 0 )
  1527.             IF( IM.EQ.2 )
  1528.      $         M = MIN( N + ND, NMAX )
  1529. *
  1530. *           Set LDA to 1 more than minimum value if room.
  1531.             LDA = M
  1532.             IF( LDA.LT.NMAX )
  1533.      $         LDA = LDA + 1
  1534. *           Skip tests if not enough room.
  1535.             IF( LDA.GT.NMAX )
  1536.      $         GO TO 110
  1537.             LAA = LDA*N
  1538.             NULL = N.LE.0.OR.M.LE.0
  1539. *
  1540.             DO 100 IX = 1, NINC
  1541.                INCX = INC( IX )
  1542.                LX = ABS( INCX )*M
  1543. *
  1544. *              Generate the vector X.
  1545. *
  1546.                TRANSL = HALF
  1547.                CALL ZMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
  1548.      $                     0, M - 1, RESET, TRANSL )
  1549.                IF( M.GT.1 )THEN
  1550.                   X( M/2 ) = ZERO
  1551.                   XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
  1552.                END IF
  1553. *
  1554.                DO 90 IY = 1, NINC
  1555.                   INCY = INC( IY )
  1556.                   LY = ABS( INCY )*N
  1557. *
  1558. *                 Generate the vector Y.
  1559. *
  1560.                   TRANSL = ZERO
  1561.                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
  1562.      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
  1563.                   IF( N.GT.1 )THEN
  1564.                      Y( N/2 ) = ZERO
  1565.                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
  1566.                   END IF
  1567. *
  1568.                   DO 80 IA = 1, NALF
  1569.                      ALPHA = ALF( IA )
  1570. *
  1571. *                    Generate the matrix A.
  1572. *
  1573.                      TRANSL = ZERO
  1574.                      CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
  1575.      $                           AA, LDA, M - 1, N - 1, RESET, TRANSL )
  1576. *
  1577.                      NC = NC + 1
  1578. *
  1579. *                    Save every datum before calling the subroutine.
  1580. *
  1581.                      MS = M
  1582.                      NS = N
  1583.                      ALS = ALPHA
  1584.                      DO 10 I = 1, LAA
  1585.                         AS( I ) = AA( I )
  1586.    10                CONTINUE
  1587.                      LDAS = LDA
  1588.                      DO 20 I = 1, LX
  1589.                         XS( I ) = XX( I )
  1590.    20                CONTINUE
  1591.                      INCXS = INCX
  1592.                      DO 30 I = 1, LY
  1593.                         YS( I ) = YY( I )
  1594.    30                CONTINUE
  1595.                      INCYS = INCY
  1596. *
  1597. *                    Call the subroutine.
  1598. *
  1599.                      IF( TRACE )
  1600.      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
  1601.      $                  ALPHA, INCX, INCY, LDA
  1602.                      IF( CONJ )THEN
  1603.                         IF( REWI )
  1604.      $                     REWIND NTRA
  1605.                         CALL ZGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA,
  1606.      $                              LDA )
  1607.                      ELSE
  1608.                         IF( REWI )
  1609.      $                     REWIND NTRA
  1610.                         CALL ZGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA,
  1611.      $                              LDA )
  1612.                      END IF
  1613. *
  1614. *                    Check if error-exit was taken incorrectly.
  1615. *
  1616.                      IF( .NOT.OK )THEN
  1617.                         WRITE( NOUT, FMT = 9993 )
  1618.                         FATAL = .TRUE.
  1619.                         GO TO 140
  1620.                      END IF
  1621. *
  1622. *                    See what data changed inside subroutine.
  1623. *
  1624.                      ISAME( 1 ) = MS.EQ.M
  1625.                      ISAME( 2 ) = NS.EQ.N
  1626.                      ISAME( 3 ) = ALS.EQ.ALPHA
  1627.                      ISAME( 4 ) = LZE( XS, XX, LX )
  1628.                      ISAME( 5 ) = INCXS.EQ.INCX
  1629.                      ISAME( 6 ) = LZE( YS, YY, LY )
  1630.                      ISAME( 7 ) = INCYS.EQ.INCY
  1631.                      IF( NULL )THEN
  1632.                         ISAME( 8 ) = LZE( AS, AA, LAA )
  1633.                      ELSE
  1634.                         ISAME( 8 ) = LZERES( 'GE', ' ', M, N, AS, AA,
  1635.      $                               LDA )
  1636.                      END IF
  1637.                      ISAME( 9 ) = LDAS.EQ.LDA
  1638. *
  1639. *                    If data was incorrectly changed, report and return.
  1640. *
  1641.                      SAME = .TRUE.
  1642.                      DO 40 I = 1, NARGS
  1643.                         SAME = SAME.AND.ISAME( I )
  1644.                         IF( .NOT.ISAME( I ) )
  1645.      $                     WRITE( NOUT, FMT = 9998 )I
  1646.    40                CONTINUE
  1647.                      IF( .NOT.SAME )THEN
  1648.                         FATAL = .TRUE.
  1649.                         GO TO 140
  1650.                      END IF
  1651. *
  1652.                      IF( .NOT.NULL )THEN
  1653. *
  1654. *                       Check the result column by column.
  1655. *
  1656.                         IF( INCX.GT.0 )THEN
  1657.                            DO 50 I = 1, M
  1658.                               Z( I ) = X( I )
  1659.    50                      CONTINUE
  1660.                         ELSE
  1661.                            DO 60 I = 1, M
  1662.                               Z( I ) = X( M - I + 1 )
  1663.    60                      CONTINUE
  1664.                         END IF
  1665.                         DO 70 J = 1, N
  1666.                            IF( INCY.GT.0 )THEN
  1667.                               W( 1 ) = Y( J )
  1668.                            ELSE
  1669.                               W( 1 ) = Y( N - J + 1 )
  1670.                            END IF
  1671.                            IF( CONJ )
  1672.      $                        W( 1 ) = DCONJG( W( 1 ) )
  1673.                            CALL ZMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
  1674.      $                                 ONE, A( 1, J ), 1, YT, G,
  1675.      $                                 AA( 1 + ( J - 1 )*LDA ), EPS,
  1676.      $                                 ERR, FATAL, NOUT, .TRUE. )
  1677.                            ERRMAX = MAX( ERRMAX, ERR )
  1678. *                          If got really bad answer, report and return.
  1679.                            IF( FATAL )
  1680.      $                        GO TO 130
  1681.    70                   CONTINUE
  1682.                      ELSE
  1683. *                       Avoid repeating tests with M.le.0 or N.le.0.
  1684.                         GO TO 110
  1685.                      END IF
  1686. *
  1687.    80             CONTINUE
  1688. *
  1689.    90          CONTINUE
  1690. *
  1691.   100       CONTINUE
  1692. *
  1693.   110    CONTINUE
  1694. *
  1695.   120 CONTINUE
  1696. *
  1697. *     Report result.
  1698. *
  1699.       IF( ERRMAX.LT.THRESH )THEN
  1700.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1701.       ELSE
  1702.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1703.       END IF
  1704.       GO TO 150
  1705. *
  1706.   130 CONTINUE
  1707.       WRITE( NOUT, FMT = 9995 )J
  1708. *
  1709.   140 CONTINUE
  1710.       WRITE( NOUT, FMT = 9996 )SNAME
  1711.       WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
  1712. *
  1713.   150 CONTINUE
  1714.       RETURN
  1715. *
  1716.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1717.      $      'S)' )
  1718.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1719.      $      'ANGED INCORRECTLY *******' )
  1720.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1721.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1722.      $      ' - SUSPECT *******' )
  1723.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1724.  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  1725.  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1,
  1726.      $      '), X,', I2, ', Y,', I2, ', A,', I3, ')                   ',
  1727.      $      '      .' )
  1728.  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1729.      $      '******' )
  1730. *
  1731. *     End of ZCHK4.
  1732. *
  1733.       END
  1734.       SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  1735.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
  1736.      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
  1737.      $                  Z )
  1738. *
  1739. *  Tests ZHER and ZHPR.
  1740. *
  1741. *  Auxiliary routine for test program for Level 2 Blas.
  1742. *
  1743. *  -- Written on 10-August-1987.
  1744. *     Richard Hanson, Sandia National Labs.
  1745. *     Jeremy Du Croz, NAG Central Office.
  1746. *
  1747. *     .. Parameters ..
  1748.       COMPLEX*16         ZERO, HALF, ONE
  1749.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  1750.      $                   HALF = ( 0.5D0, 0.0D0 ),
  1751.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  1752.       DOUBLE PRECISION   RZERO
  1753.       PARAMETER          ( RZERO = 0.0D0 )
  1754. *     .. Scalar Arguments ..
  1755.       DOUBLE PRECISION   EPS, THRESH
  1756.       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
  1757.       LOGICAL            FATAL, REWI, TRACE
  1758.       CHARACTER*6        SNAME
  1759. *     .. Array Arguments ..
  1760.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  1761.      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
  1762.      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  1763.      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  1764.      $                   YY( NMAX*INCMAX ), Z( NMAX )
  1765.       DOUBLE PRECISION   G( NMAX )
  1766.       INTEGER            IDIM( NIDIM ), INC( NINC )
  1767. *     .. Local Scalars ..
  1768.       COMPLEX*16         ALPHA, TRANSL
  1769.       DOUBLE PRECISION   ERR, ERRMAX, RALPHA, RALS
  1770.       INTEGER            I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
  1771.      $                   LDA, LDAS, LJ, LX, N, NARGS, NC, NS
  1772.       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
  1773.       CHARACTER*1        UPLO, UPLOS
  1774.       CHARACTER*2        ICH
  1775. *     .. Local Arrays ..
  1776.       COMPLEX*16         W( 1 )
  1777.       LOGICAL            ISAME( 13 )
  1778. *     .. External Functions ..
  1779.       LOGICAL            LZE, LZERES
  1780.       EXTERNAL           LZE, LZERES
  1781. *     .. External Subroutines ..
  1782.       EXTERNAL           ZHER, ZHPR, ZMAKE, ZMVCH
  1783. *     .. Intrinsic Functions ..
  1784.       INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, MAX
  1785. *     .. Scalars in Common ..
  1786.       INTEGER            INFOT, NOUTC
  1787.       LOGICAL            LERR, OK
  1788. *     .. Common blocks ..
  1789.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1790. *     .. Data statements ..
  1791.       DATA               ICH/'UL'/
  1792. *     .. Executable Statements ..
  1793.       FULL = SNAME( 3: 3 ).EQ.'E'
  1794.       PACKED = SNAME( 3: 3 ).EQ.'P'
  1795. *     Define the number of arguments.
  1796.       IF( FULL )THEN
  1797.          NARGS = 7
  1798.       ELSE IF( PACKED )THEN
  1799.          NARGS = 6
  1800.       END IF
  1801. *
  1802.       NC = 0
  1803.       RESET = .TRUE.
  1804.       ERRMAX = RZERO
  1805. *
  1806.       DO 100 IN = 1, NIDIM
  1807.          N = IDIM( IN )
  1808. *        Set LDA to 1 more than minimum value if room.
  1809.          LDA = N
  1810.          IF( LDA.LT.NMAX )
  1811.      $      LDA = LDA + 1
  1812. *        Skip tests if not enough room.
  1813.          IF( LDA.GT.NMAX )
  1814.      $      GO TO 100
  1815.          IF( PACKED )THEN
  1816.             LAA = ( N*( N + 1 ) )/2
  1817.          ELSE
  1818.             LAA = LDA*N
  1819.          END IF
  1820. *
  1821.          DO 90 IC = 1, 2
  1822.             UPLO = ICH( IC: IC )
  1823.             UPPER = UPLO.EQ.'U'
  1824. *
  1825.             DO 80 IX = 1, NINC
  1826.                INCX = INC( IX )
  1827.                LX = ABS( INCX )*N
  1828. *
  1829. *              Generate the vector X.
  1830. *
  1831.                TRANSL = HALF
  1832.                CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
  1833.      $                     0, N - 1, RESET, TRANSL )
  1834.                IF( N.GT.1 )THEN
  1835.                   X( N/2 ) = ZERO
  1836.                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
  1837.                END IF
  1838. *
  1839.                DO 70 IA = 1, NALF
  1840.                   RALPHA = DBLE( ALF( IA ) )
  1841.                   ALPHA = DCMPLX( RALPHA, RZERO )
  1842.                   NULL = N.LE.0.OR.RALPHA.EQ.RZERO
  1843. *
  1844. *                 Generate the matrix A.
  1845. *
  1846.                   TRANSL = ZERO
  1847.                   CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
  1848.      $                        AA, LDA, N - 1, N - 1, RESET, TRANSL )
  1849. *
  1850.                   NC = NC + 1
  1851. *
  1852. *                 Save every datum before calling the subroutine.
  1853. *
  1854.                   UPLOS = UPLO
  1855.                   NS = N
  1856.                   RALS = RALPHA
  1857.                   DO 10 I = 1, LAA
  1858.                      AS( I ) = AA( I )
  1859.    10             CONTINUE
  1860.                   LDAS = LDA
  1861.                   DO 20 I = 1, LX
  1862.                      XS( I ) = XX( I )
  1863.    20             CONTINUE
  1864.                   INCXS = INCX
  1865. *
  1866. *                 Call the subroutine.
  1867. *
  1868.                   IF( FULL )THEN
  1869.                      IF( TRACE )
  1870.      $                  WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
  1871.      $                  RALPHA, INCX, LDA
  1872.                      IF( REWI )
  1873.      $                  REWIND NTRA
  1874.                      CALL ZHER( UPLO, N, RALPHA, XX, INCX, AA, LDA )
  1875.                   ELSE IF( PACKED )THEN
  1876.                      IF( TRACE )
  1877.      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
  1878.      $                  RALPHA, INCX
  1879.                      IF( REWI )
  1880.      $                  REWIND NTRA
  1881.                      CALL ZHPR( UPLO, N, RALPHA, XX, INCX, AA )
  1882.                   END IF
  1883. *
  1884. *                 Check if error-exit was taken incorrectly.
  1885. *
  1886.                   IF( .NOT.OK )THEN
  1887.                      WRITE( NOUT, FMT = 9992 )
  1888.                      FATAL = .TRUE.
  1889.                      GO TO 120
  1890.                   END IF
  1891. *
  1892. *                 See what data changed inside subroutines.
  1893. *
  1894.                   ISAME( 1 ) = UPLO.EQ.UPLOS
  1895.                   ISAME( 2 ) = NS.EQ.N
  1896.                   ISAME( 3 ) = RALS.EQ.RALPHA
  1897.                   ISAME( 4 ) = LZE( XS, XX, LX )
  1898.                   ISAME( 5 ) = INCXS.EQ.INCX
  1899.                   IF( NULL )THEN
  1900.                      ISAME( 6 ) = LZE( AS, AA, LAA )
  1901.                   ELSE
  1902.                      ISAME( 6 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, AS,
  1903.      $                            AA, LDA )
  1904.                   END IF
  1905.                   IF( .NOT.PACKED )THEN
  1906.                      ISAME( 7 ) = LDAS.EQ.LDA
  1907.                   END IF
  1908. *
  1909. *                 If data was incorrectly changed, report and return.
  1910. *
  1911.                   SAME = .TRUE.
  1912.                   DO 30 I = 1, NARGS
  1913.                      SAME = SAME.AND.ISAME( I )
  1914.                      IF( .NOT.ISAME( I ) )
  1915.      $                  WRITE( NOUT, FMT = 9998 )I
  1916.    30             CONTINUE
  1917.                   IF( .NOT.SAME )THEN
  1918.                      FATAL = .TRUE.
  1919.                      GO TO 120
  1920.                   END IF
  1921. *
  1922.                   IF( .NOT.NULL )THEN
  1923. *
  1924. *                    Check the result column by column.
  1925. *
  1926.                      IF( INCX.GT.0 )THEN
  1927.                         DO 40 I = 1, N
  1928.                            Z( I ) = X( I )
  1929.    40                   CONTINUE
  1930.                      ELSE
  1931.                         DO 50 I = 1, N
  1932.                            Z( I ) = X( N - I + 1 )
  1933.    50                   CONTINUE
  1934.                      END IF
  1935.                      JA = 1
  1936.                      DO 60 J = 1, N
  1937.                         W( 1 ) = DCONJG( Z( J ) )
  1938.                         IF( UPPER )THEN
  1939.                            JJ = 1
  1940.                            LJ = J
  1941.                         ELSE
  1942.                            JJ = J
  1943.                            LJ = N - J + 1
  1944.                         END IF
  1945.                         CALL ZMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
  1946.      $                              1, ONE, A( JJ, J ), 1, YT, G,
  1947.      $                              AA( JA ), EPS, ERR, FATAL, NOUT,
  1948.      $                              .TRUE. )
  1949.                         IF( FULL )THEN
  1950.                            IF( UPPER )THEN
  1951.                               JA = JA + LDA
  1952.                            ELSE
  1953.                               JA = JA + LDA + 1
  1954.                            END IF
  1955.                         ELSE
  1956.                            JA = JA + LJ
  1957.                         END IF
  1958.                         ERRMAX = MAX( ERRMAX, ERR )
  1959. *                       If got really bad answer, report and return.
  1960.                         IF( FATAL )
  1961.      $                     GO TO 110
  1962.    60                CONTINUE
  1963.                   ELSE
  1964. *                    Avoid repeating tests if N.le.0.
  1965.                      IF( N.LE.0 )
  1966.      $                  GO TO 100
  1967.                   END IF
  1968. *
  1969.    70          CONTINUE
  1970. *
  1971.    80       CONTINUE
  1972. *
  1973.    90    CONTINUE
  1974. *
  1975.   100 CONTINUE
  1976. *
  1977. *     Report result.
  1978. *
  1979.       IF( ERRMAX.LT.THRESH )THEN
  1980.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1981.       ELSE
  1982.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1983.       END IF
  1984.       GO TO 130
  1985. *
  1986.   110 CONTINUE
  1987.       WRITE( NOUT, FMT = 9995 )J
  1988. *
  1989.   120 CONTINUE
  1990.       WRITE( NOUT, FMT = 9996 )SNAME
  1991.       IF( FULL )THEN
  1992.          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA
  1993.       ELSE IF( PACKED )THEN
  1994.          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX
  1995.       END IF
  1996. *
  1997.   130 CONTINUE
  1998.       RETURN
  1999. *
  2000.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  2001.      $      'S)' )
  2002.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  2003.      $      'ANGED INCORRECTLY *******' )
  2004.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  2005.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  2006.      $      ' - SUSPECT *******' )
  2007.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  2008.  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  2009.  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
  2010.      $      I2, ', AP)                                         .' )
  2011.  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
  2012.      $      I2, ', A,', I3, ')                                      .' )
  2013.  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  2014.      $      '******' )
  2015. *
  2016. *     End of ZCHK5.
  2017. *
  2018.       END
  2019.       SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  2020.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
  2021.      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
  2022.      $                  Z )
  2023. *
  2024. *  Tests ZHER2 and ZHPR2.
  2025. *
  2026. *  Auxiliary routine for test program for Level 2 Blas.
  2027. *
  2028. *  -- Written on 10-August-1987.
  2029. *     Richard Hanson, Sandia National Labs.
  2030. *     Jeremy Du Croz, NAG Central Office.
  2031. *
  2032. *     .. Parameters ..
  2033.       COMPLEX*16         ZERO, HALF, ONE
  2034.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  2035.      $                   HALF = ( 0.5D0, 0.0D0 ),
  2036.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  2037.       DOUBLE PRECISION   RZERO
  2038.       PARAMETER          ( RZERO = 0.0D0 )
  2039. *     .. Scalar Arguments ..
  2040.       DOUBLE PRECISION   EPS, THRESH
  2041.       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
  2042.       LOGICAL            FATAL, REWI, TRACE
  2043.       CHARACTER*6        SNAME
  2044. *     .. Array Arguments ..
  2045.       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  2046.      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
  2047.      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  2048.      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  2049.      $                   YY( NMAX*INCMAX ), Z( NMAX, 2 )
  2050.       DOUBLE PRECISION   G( NMAX )
  2051.       INTEGER            IDIM( NIDIM ), INC( NINC )
  2052. *     .. Local Scalars ..
  2053.       COMPLEX*16         ALPHA, ALS, TRANSL
  2054.       DOUBLE PRECISION   ERR, ERRMAX
  2055.       INTEGER            I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
  2056.      $                   IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
  2057.      $                   NARGS, NC, NS
  2058.       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
  2059.       CHARACTER*1        UPLO, UPLOS
  2060.       CHARACTER*2        ICH
  2061. *     .. Local Arrays ..
  2062.       COMPLEX*16         W( 2 )
  2063.       LOGICAL            ISAME( 13 )
  2064. *     .. External Functions ..
  2065.       LOGICAL            LZE, LZERES
  2066.       EXTERNAL           LZE, LZERES
  2067. *     .. External Subroutines ..
  2068.       EXTERNAL           ZHER2, ZHPR2, ZMAKE, ZMVCH
  2069. *     .. Intrinsic Functions ..
  2070.       INTRINSIC          ABS, DCONJG, MAX
  2071. *     .. Scalars in Common ..
  2072.       INTEGER            INFOT, NOUTC
  2073.       LOGICAL            LERR, OK
  2074. *     .. Common blocks ..
  2075.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  2076. *     .. Data statements ..
  2077.       DATA               ICH/'UL'/
  2078. *     .. Executable Statements ..
  2079.       FULL = SNAME( 3: 3 ).EQ.'E'
  2080.       PACKED = SNAME( 3: 3 ).EQ.'P'
  2081. *     Define the number of arguments.
  2082.       IF( FULL )THEN
  2083.          NARGS = 9
  2084.       ELSE IF( PACKED )THEN
  2085.          NARGS = 8
  2086.       END IF
  2087. *
  2088.       NC = 0
  2089.       RESET = .TRUE.
  2090.       ERRMAX = RZERO
  2091. *
  2092.       DO 140 IN = 1, NIDIM
  2093.          N = IDIM( IN )
  2094. *        Set LDA to 1 more than minimum value if room.
  2095.          LDA = N
  2096.          IF( LDA.LT.NMAX )
  2097.      $      LDA = LDA + 1
  2098. *        Skip tests if not enough room.
  2099.          IF( LDA.GT.NMAX )
  2100.      $      GO TO 140
  2101.          IF( PACKED )THEN
  2102.             LAA = ( N*( N + 1 ) )/2
  2103.          ELSE
  2104.             LAA = LDA*N
  2105.          END IF
  2106. *
  2107.          DO 130 IC = 1, 2
  2108.             UPLO = ICH( IC: IC )
  2109.             UPPER = UPLO.EQ.'U'
  2110. *
  2111.             DO 120 IX = 1, NINC
  2112.                INCX = INC( IX )
  2113.                LX = ABS( INCX )*N
  2114. *
  2115. *              Generate the vector X.
  2116. *
  2117.                TRANSL = HALF
  2118.                CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
  2119.      $                     0, N - 1, RESET, TRANSL )
  2120.                IF( N.GT.1 )THEN
  2121.                   X( N/2 ) = ZERO
  2122.                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
  2123.                END IF
  2124. *
  2125.                DO 110 IY = 1, NINC
  2126.                   INCY = INC( IY )
  2127.                   LY = ABS( INCY )*N
  2128. *
  2129. *                 Generate the vector Y.
  2130. *
  2131.                   TRANSL = ZERO
  2132.                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
  2133.      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
  2134.                   IF( N.GT.1 )THEN
  2135.                      Y( N/2 ) = ZERO
  2136.                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
  2137.                   END IF
  2138. *
  2139.                   DO 100 IA = 1, NALF
  2140.                      ALPHA = ALF( IA )
  2141.                      NULL = N.LE.0.OR.ALPHA.EQ.ZERO
  2142. *
  2143. *                    Generate the matrix A.
  2144. *
  2145.                      TRANSL = ZERO
  2146.                      CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
  2147.      $                           NMAX, AA, LDA, N - 1, N - 1, RESET,
  2148.      $                           TRANSL )
  2149. *
  2150.                      NC = NC + 1
  2151. *
  2152. *                    Save every datum before calling the subroutine.
  2153. *
  2154.                      UPLOS = UPLO
  2155.                      NS = N
  2156.                      ALS = ALPHA
  2157.                      DO 10 I = 1, LAA
  2158.                         AS( I ) = AA( I )
  2159.    10                CONTINUE
  2160.                      LDAS = LDA
  2161.                      DO 20 I = 1, LX
  2162.                         XS( I ) = XX( I )
  2163.    20                CONTINUE
  2164.                      INCXS = INCX
  2165.                      DO 30 I = 1, LY
  2166.                         YS( I ) = YY( I )
  2167.    30                CONTINUE
  2168.                      INCYS = INCY
  2169. *
  2170. *                    Call the subroutine.
  2171. *
  2172.                      IF( FULL )THEN
  2173.                         IF( TRACE )
  2174.      $                     WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
  2175.      $                     ALPHA, INCX, INCY, LDA
  2176.                         IF( REWI )
  2177.      $                     REWIND NTRA
  2178.                         CALL ZHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
  2179.      $                              AA, LDA )
  2180.                      ELSE IF( PACKED )THEN
  2181.                         IF( TRACE )
  2182.      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
  2183.      $                     ALPHA, INCX, INCY
  2184.                         IF( REWI )
  2185.      $                     REWIND NTRA
  2186.                         CALL ZHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
  2187.      $                              AA )
  2188.                      END IF
  2189. *
  2190. *                    Check if error-exit was taken incorrectly.
  2191. *
  2192.                      IF( .NOT.OK )THEN
  2193.                         WRITE( NOUT, FMT = 9992 )
  2194.                         FATAL = .TRUE.
  2195.                         GO TO 160
  2196.                      END IF
  2197. *
  2198. *                    See what data changed inside subroutines.
  2199. *
  2200.                      ISAME( 1 ) = UPLO.EQ.UPLOS
  2201.                      ISAME( 2 ) = NS.EQ.N
  2202.                      ISAME( 3 ) = ALS.EQ.ALPHA
  2203.                      ISAME( 4 ) = LZE( XS, XX, LX )
  2204.                      ISAME( 5 ) = INCXS.EQ.INCX
  2205.                      ISAME( 6 ) = LZE( YS, YY, LY )
  2206.                      ISAME( 7 ) = INCYS.EQ.INCY
  2207.                      IF( NULL )THEN
  2208.                         ISAME( 8 ) = LZE( AS, AA, LAA )
  2209.                      ELSE
  2210.                         ISAME( 8 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N,
  2211.      $                               AS, AA, LDA )
  2212.                      END IF
  2213.                      IF( .NOT.PACKED )THEN
  2214.                         ISAME( 9 ) = LDAS.EQ.LDA
  2215.                      END IF
  2216. *
  2217. *                    If data was incorrectly changed, report and return.
  2218. *
  2219.                      SAME = .TRUE.
  2220.                      DO 40 I = 1, NARGS
  2221.                         SAME = SAME.AND.ISAME( I )
  2222.                         IF( .NOT.ISAME( I ) )
  2223.      $                     WRITE( NOUT, FMT = 9998 )I
  2224.    40                CONTINUE
  2225.                      IF( .NOT.SAME )THEN
  2226.                         FATAL = .TRUE.
  2227.                         GO TO 160
  2228.                      END IF
  2229. *
  2230.                      IF( .NOT.NULL )THEN
  2231. *
  2232. *                       Check the result column by column.
  2233. *
  2234.                         IF( INCX.GT.0 )THEN
  2235.                            DO 50 I = 1, N
  2236.                               Z( I, 1 ) = X( I )
  2237.    50                      CONTINUE
  2238.                         ELSE
  2239.                            DO 60 I = 1, N
  2240.                               Z( I, 1 ) = X( N - I + 1 )
  2241.    60                      CONTINUE
  2242.                         END IF
  2243.                         IF( INCY.GT.0 )THEN
  2244.                            DO 70 I = 1, N
  2245.                               Z( I, 2 ) = Y( I )
  2246.    70                      CONTINUE
  2247.                         ELSE
  2248.                            DO 80 I = 1, N
  2249.                               Z( I, 2 ) = Y( N - I + 1 )
  2250.    80                      CONTINUE
  2251.                         END IF
  2252.                         JA = 1
  2253.                         DO 90 J = 1, N
  2254.                            W( 1 ) = ALPHA*DCONJG( Z( J, 2 ) )
  2255.                            W( 2 ) = DCONJG( ALPHA )*DCONJG( Z( J, 1 ) )
  2256.                            IF( UPPER )THEN
  2257.                               JJ = 1
  2258.                               LJ = J
  2259.                            ELSE
  2260.                               JJ = J
  2261.                               LJ = N - J + 1
  2262.                            END IF
  2263.                            CALL ZMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ),
  2264.      $                                 NMAX, W, 1, ONE, A( JJ, J ), 1,
  2265.      $                                 YT, G, AA( JA ), EPS, ERR, FATAL,
  2266.      $                                 NOUT, .TRUE. )
  2267.                            IF( FULL )THEN
  2268.                               IF( UPPER )THEN
  2269.                                  JA = JA + LDA
  2270.                               ELSE
  2271.                                  JA = JA + LDA + 1
  2272.                               END IF
  2273.                            ELSE
  2274.                               JA = JA + LJ
  2275.                            END IF
  2276.                            ERRMAX = MAX( ERRMAX, ERR )
  2277. *                          If got really bad answer, report and return.
  2278.                            IF( FATAL )
  2279.      $                        GO TO 150
  2280.    90                   CONTINUE
  2281.                      ELSE
  2282. *                       Avoid repeating tests with N.le.0.
  2283.                         IF( N.LE.0 )
  2284.      $                     GO TO 140
  2285.                      END IF
  2286. *
  2287.   100             CONTINUE
  2288. *
  2289.   110          CONTINUE
  2290. *
  2291.   120       CONTINUE
  2292. *
  2293.   130    CONTINUE
  2294. *
  2295.   140 CONTINUE
  2296. *
  2297. *     Report result.
  2298. *
  2299.       IF( ERRMAX.LT.THRESH )THEN
  2300.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  2301.       ELSE
  2302.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  2303.       END IF
  2304.       GO TO 170
  2305. *
  2306.   150 CONTINUE
  2307.       WRITE( NOUT, FMT = 9995 )J
  2308. *
  2309.   160 CONTINUE
  2310.       WRITE( NOUT, FMT = 9996 )SNAME
  2311.       IF( FULL )THEN
  2312.          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
  2313.      $      INCY, LDA
  2314.       ELSE IF( PACKED )THEN
  2315.          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
  2316.       END IF
  2317. *
  2318.   170 CONTINUE
  2319.       RETURN
  2320. *
  2321.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  2322.      $      'S)' )
  2323.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  2324.      $      'ANGED INCORRECTLY *******' )
  2325.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  2326.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  2327.      $      ' - SUSPECT *******' )
  2328.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  2329.  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  2330.  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
  2331.      $      F4.1, '), X,', I2, ', Y,', I2, ', AP)                     ',
  2332.      $      '       .' )
  2333.  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
  2334.      $      F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ')             ',
  2335.      $      '            .' )
  2336.  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  2337.      $      '******' )
  2338. *
  2339. *     End of ZCHK6.
  2340. *
  2341.       END
  2342.       SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT )
  2343. *
  2344. *  Tests the error exits from the Level 2 Blas.
  2345. *  Requires a special version of the error-handling routine XERBLA.
  2346. *  ALPHA, RALPHA, BETA, A, X and Y should not need to be defined.
  2347. *
  2348. *  Auxiliary routine for test program for Level 2 Blas.
  2349. *
  2350. *  -- Written on 10-August-1987.
  2351. *     Richard Hanson, Sandia National Labs.
  2352. *     Jeremy Du Croz, NAG Central Office.
  2353. *
  2354. *     .. Scalar Arguments ..
  2355.       INTEGER            ISNUM, NOUT
  2356.       CHARACTER*6        SRNAMT
  2357. *     .. Scalars in Common ..
  2358.       INTEGER            INFOT, NOUTC
  2359.       LOGICAL            LERR, OK
  2360. *     .. Local Scalars ..
  2361.       COMPLEX*16         ALPHA, BETA
  2362.       DOUBLE PRECISION   RALPHA
  2363. *     .. Local Arrays ..
  2364.       COMPLEX*16         A( 1, 1 ), X( 1 ), Y( 1 )
  2365. *     .. External Subroutines ..
  2366.       EXTERNAL           CHKXER, ZGBMV, ZGEMV, ZGERC, ZGERU, ZHBMV,
  2367.      $                   ZHEMV, ZHER, ZHER2, ZHPMV, ZHPR, ZHPR2, ZTBMV,
  2368.      $                   ZTBSV, ZTPMV, ZTPSV, ZTRMV, ZTRSV
  2369. *     .. Common blocks ..
  2370.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  2371. *     .. Executable Statements ..
  2372. *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
  2373. *     if anything is wrong.
  2374.       OK = .TRUE.
  2375. *     LERR is set to .TRUE. by the special version of XERBLA each time
  2376. *     it is called, and is then tested and re-set by CHKXER.
  2377.       LERR = .FALSE.
  2378.       GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
  2379.      $        90, 100, 110, 120, 130, 140, 150, 160,
  2380.      $        170 )ISNUM
  2381.    10 INFOT = 1
  2382.       CALL ZGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2383.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2384.       INFOT = 2
  2385.       CALL ZGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2386.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2387.       INFOT = 3
  2388.       CALL ZGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2389.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2390.       INFOT = 6
  2391.       CALL ZGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2392.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2393.       INFOT = 8
  2394.       CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
  2395.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2396.       INFOT = 11
  2397.       CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
  2398.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2399.       GO TO 180
  2400.    20 INFOT = 1
  2401.       CALL ZGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2402.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2403.       INFOT = 2
  2404.       CALL ZGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2405.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2406.       INFOT = 3
  2407.       CALL ZGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2408.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2409.       INFOT = 4
  2410.       CALL ZGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2411.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2412.       INFOT = 5
  2413.       CALL ZGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2414.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2415.       INFOT = 8
  2416.       CALL ZGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2417.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2418.       INFOT = 10
  2419.       CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
  2420.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2421.       INFOT = 13
  2422.       CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
  2423.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2424.       GO TO 180
  2425.    30 INFOT = 1
  2426.       CALL ZHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2427.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2428.       INFOT = 2
  2429.       CALL ZHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2430.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2431.       INFOT = 5
  2432.       CALL ZHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2433.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2434.       INFOT = 7
  2435.       CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
  2436.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2437.       INFOT = 10
  2438.       CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
  2439.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2440.       GO TO 180
  2441.    40 INFOT = 1
  2442.       CALL ZHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2443.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2444.       INFOT = 2
  2445.       CALL ZHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2446.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2447.       INFOT = 3
  2448.       CALL ZHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2449.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2450.       INFOT = 6
  2451.       CALL ZHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
  2452.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2453.       INFOT = 8
  2454.       CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
  2455.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2456.       INFOT = 11
  2457.       CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
  2458.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2459.       GO TO 180
  2460.    50 INFOT = 1
  2461.       CALL ZHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
  2462.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2463.       INFOT = 2
  2464.       CALL ZHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
  2465.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2466.       INFOT = 6
  2467.       CALL ZHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
  2468.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2469.       INFOT = 9
  2470.       CALL ZHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
  2471.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2472.       GO TO 180
  2473.    60 INFOT = 1
  2474.       CALL ZTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
  2475.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2476.       INFOT = 2
  2477.       CALL ZTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
  2478.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2479.       INFOT = 3
  2480.       CALL ZTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
  2481.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2482.       INFOT = 4
  2483.       CALL ZTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
  2484.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2485.       INFOT = 6
  2486.       CALL ZTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
  2487.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2488.       INFOT = 8
  2489.       CALL ZTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
  2490.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2491.       GO TO 180
  2492.    70 INFOT = 1
  2493.       CALL ZTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
  2494.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2495.       INFOT = 2
  2496.       CALL ZTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
  2497.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2498.       INFOT = 3
  2499.       CALL ZTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
  2500.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2501.       INFOT = 4
  2502.       CALL ZTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
  2503.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2504.       INFOT = 5
  2505.       CALL ZTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
  2506.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2507.       INFOT = 7
  2508.       CALL ZTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
  2509.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2510.       INFOT = 9
  2511.       CALL ZTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
  2512.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2513.       GO TO 180
  2514.    80 INFOT = 1
  2515.       CALL ZTPMV( '/', 'N', 'N', 0, A, X, 1 )
  2516.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2517.       INFOT = 2
  2518.       CALL ZTPMV( 'U', '/', 'N', 0, A, X, 1 )
  2519.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2520.       INFOT = 3
  2521.       CALL ZTPMV( 'U', 'N', '/', 0, A, X, 1 )
  2522.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2523.       INFOT = 4
  2524.       CALL ZTPMV( 'U', 'N', 'N', -1, A, X, 1 )
  2525.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2526.       INFOT = 7
  2527.       CALL ZTPMV( 'U', 'N', 'N', 0, A, X, 0 )
  2528.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2529.       GO TO 180
  2530.    90 INFOT = 1
  2531.       CALL ZTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
  2532.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2533.       INFOT = 2
  2534.       CALL ZTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
  2535.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2536.       INFOT = 3
  2537.       CALL ZTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
  2538.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2539.       INFOT = 4
  2540.       CALL ZTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
  2541.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2542.       INFOT = 6
  2543.       CALL ZTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
  2544.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2545.       INFOT = 8
  2546.       CALL ZTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
  2547.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2548.       GO TO 180
  2549.   100 INFOT = 1
  2550.       CALL ZTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
  2551.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2552.       INFOT = 2
  2553.       CALL ZTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
  2554.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2555.       INFOT = 3
  2556.       CALL ZTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
  2557.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2558.       INFOT = 4
  2559.       CALL ZTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
  2560.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2561.       INFOT = 5
  2562.       CALL ZTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
  2563.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2564.       INFOT = 7
  2565.       CALL ZTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
  2566.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2567.       INFOT = 9
  2568.       CALL ZTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
  2569.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2570.       GO TO 180
  2571.   110 INFOT = 1
  2572.       CALL ZTPSV( '/', 'N', 'N', 0, A, X, 1 )
  2573.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2574.       INFOT = 2
  2575.       CALL ZTPSV( 'U', '/', 'N', 0, A, X, 1 )
  2576.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2577.       INFOT = 3
  2578.       CALL ZTPSV( 'U', 'N', '/', 0, A, X, 1 )
  2579.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2580.       INFOT = 4
  2581.       CALL ZTPSV( 'U', 'N', 'N', -1, A, X, 1 )
  2582.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2583.       INFOT = 7
  2584.       CALL ZTPSV( 'U', 'N', 'N', 0, A, X, 0 )
  2585.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2586.       GO TO 180
  2587.   120 INFOT = 1
  2588.       CALL ZGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
  2589.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2590.       INFOT = 2
  2591.       CALL ZGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
  2592.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2593.       INFOT = 5
  2594.       CALL ZGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
  2595.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2596.       INFOT = 7
  2597.       CALL ZGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
  2598.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2599.       INFOT = 9
  2600.       CALL ZGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
  2601.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2602.       GO TO 180
  2603.   130 INFOT = 1
  2604.       CALL ZGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
  2605.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2606.       INFOT = 2
  2607.       CALL ZGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
  2608.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2609.       INFOT = 5
  2610.       CALL ZGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
  2611.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2612.       INFOT = 7
  2613.       CALL ZGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
  2614.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2615.       INFOT = 9
  2616.       CALL ZGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
  2617.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2618.       GO TO 180
  2619.   140 INFOT = 1
  2620.       CALL ZHER( '/', 0, RALPHA, X, 1, A, 1 )
  2621.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2622.       INFOT = 2
  2623.       CALL ZHER( 'U', -1, RALPHA, X, 1, A, 1 )
  2624.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2625.       INFOT = 5
  2626.       CALL ZHER( 'U', 0, RALPHA, X, 0, A, 1 )
  2627.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2628.       INFOT = 7
  2629.       CALL ZHER( 'U', 2, RALPHA, X, 1, A, 1 )
  2630.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2631.       GO TO 180
  2632.   150 INFOT = 1
  2633.       CALL ZHPR( '/', 0, RALPHA, X, 1, A )
  2634.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2635.       INFOT = 2
  2636.       CALL ZHPR( 'U', -1, RALPHA, X, 1, A )
  2637.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2638.       INFOT = 5
  2639.       CALL ZHPR( 'U', 0, RALPHA, X, 0, A )
  2640.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2641.       GO TO 180
  2642.   160 INFOT = 1
  2643.       CALL ZHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
  2644.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2645.       INFOT = 2
  2646.       CALL ZHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
  2647.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2648.       INFOT = 5
  2649.       CALL ZHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
  2650.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2651.       INFOT = 7
  2652.       CALL ZHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
  2653.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2654.       INFOT = 9
  2655.       CALL ZHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
  2656.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2657.       GO TO 180
  2658.   170 INFOT = 1
  2659.       CALL ZHPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
  2660.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2661.       INFOT = 2
  2662.       CALL ZHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
  2663.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2664.       INFOT = 5
  2665.       CALL ZHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
  2666.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2667.       INFOT = 7
  2668.       CALL ZHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
  2669.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2670. *
  2671.   180 IF( OK )THEN
  2672.          WRITE( NOUT, FMT = 9999 )SRNAMT
  2673.       ELSE
  2674.          WRITE( NOUT, FMT = 9998 )SRNAMT
  2675.       END IF
  2676.       RETURN
  2677. *
  2678.  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
  2679.  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
  2680.      $      '**' )
  2681. *
  2682. *     End of ZCHKE.
  2683. *
  2684.       END
  2685.       SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
  2686.      $                  KU, RESET, TRANSL )
  2687. *
  2688. *  Generates values for an M by N matrix A within the bandwidth
  2689. *  defined by KL and KU.
  2690. *  Stores the values in the array AA in the data structure required
  2691. *  by the routine, with unwanted elements set to rogue value.
  2692. *
  2693. *  TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
  2694. *
  2695. *  Auxiliary routine for test program for Level 2 Blas.
  2696. *
  2697. *  -- Written on 10-August-1987.
  2698. *     Richard Hanson, Sandia National Labs.
  2699. *     Jeremy Du Croz, NAG Central Office.
  2700. *
  2701. *     .. Parameters ..
  2702.       COMPLEX*16         ZERO, ONE
  2703.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  2704.      $                   ONE = ( 1.0D0, 0.0D0 ) )
  2705.       COMPLEX*16         ROGUE
  2706.       PARAMETER          ( ROGUE = ( -1.0D10, 1.0D10 ) )
  2707.       DOUBLE PRECISION   RZERO
  2708.       PARAMETER          ( RZERO = 0.0D0 )
  2709.       DOUBLE PRECISION   RROGUE
  2710.       PARAMETER          ( RROGUE = -1.0D10 )
  2711. *     .. Scalar Arguments ..
  2712.       COMPLEX*16         TRANSL
  2713.       INTEGER            KL, KU, LDA, M, N, NMAX
  2714.       LOGICAL            RESET
  2715.       CHARACTER*1        DIAG, UPLO
  2716.       CHARACTER*2        TYPE
  2717. *     .. Array Arguments ..
  2718.       COMPLEX*16         A( NMAX, * ), AA( * )
  2719. *     .. Local Scalars ..
  2720.       INTEGER            I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
  2721.       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
  2722. *     .. External Functions ..
  2723.       COMPLEX*16         ZBEG
  2724.       EXTERNAL           ZBEG
  2725. *     .. Intrinsic Functions ..
  2726.       INTRINSIC          DBLE, DCMPLX, DCONJG, MAX, MIN
  2727. *     .. Executable Statements ..
  2728.       GEN = TYPE( 1: 1 ).EQ.'G'
  2729.       SYM = TYPE( 1: 1 ).EQ.'H'
  2730.       TRI = TYPE( 1: 1 ).EQ.'T'
  2731.       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
  2732.       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
  2733.       UNIT = TRI.AND.DIAG.EQ.'U'
  2734. *
  2735. *     Generate data in array A.
  2736. *
  2737.       DO 20 J = 1, N
  2738.          DO 10 I = 1, M
  2739.             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
  2740.      $          THEN
  2741.                IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
  2742.      $             ( I.GE.J.AND.I - J.LE.KL ) )THEN
  2743.                   A( I, J ) = ZBEG( RESET ) + TRANSL
  2744.                ELSE
  2745.                   A( I, J ) = ZERO
  2746.                END IF
  2747.                IF( I.NE.J )THEN
  2748.                   IF( SYM )THEN
  2749.                      A( J, I ) = DCONJG( A( I, J ) )
  2750.                   ELSE IF( TRI )THEN
  2751.                      A( J, I ) = ZERO
  2752.                   END IF
  2753.                END IF
  2754.             END IF
  2755.    10    CONTINUE
  2756.          IF( SYM )
  2757.      $      A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO )
  2758.          IF( TRI )
  2759.      $      A( J, J ) = A( J, J ) + ONE
  2760.          IF( UNIT )
  2761.      $      A( J, J ) = ONE
  2762.    20 CONTINUE
  2763. *
  2764. *     Store elements in array AS in data structure required by routine.
  2765. *
  2766.       IF( TYPE.EQ.'GE' )THEN
  2767.          DO 50 J = 1, N
  2768.             DO 30 I = 1, M
  2769.                AA( I + ( J - 1 )*LDA ) = A( I, J )
  2770.    30       CONTINUE
  2771.             DO 40 I = M + 1, LDA
  2772.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2773.    40       CONTINUE
  2774.    50    CONTINUE
  2775.       ELSE IF( TYPE.EQ.'GB' )THEN
  2776.          DO 90 J = 1, N
  2777.             DO 60 I1 = 1, KU + 1 - J
  2778.                AA( I1 + ( J - 1 )*LDA ) = ROGUE
  2779.    60       CONTINUE
  2780.             DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
  2781.                AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
  2782.    70       CONTINUE
  2783.             DO 80 I3 = I2, LDA
  2784.                AA( I3 + ( J - 1 )*LDA ) = ROGUE
  2785.    80       CONTINUE
  2786.    90    CONTINUE
  2787.       ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN
  2788.          DO 130 J = 1, N
  2789.             IF( UPPER )THEN
  2790.                IBEG = 1
  2791.                IF( UNIT )THEN
  2792.                   IEND = J - 1
  2793.                ELSE
  2794.                   IEND = J
  2795.                END IF
  2796.             ELSE
  2797.                IF( UNIT )THEN
  2798.                   IBEG = J + 1
  2799.                ELSE
  2800.                   IBEG = J
  2801.                END IF
  2802.                IEND = N
  2803.             END IF
  2804.             DO 100 I = 1, IBEG - 1
  2805.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2806.   100       CONTINUE
  2807.             DO 110 I = IBEG, IEND
  2808.                AA( I + ( J - 1 )*LDA ) = A( I, J )
  2809.   110       CONTINUE
  2810.             DO 120 I = IEND + 1, LDA
  2811.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2812.   120       CONTINUE
  2813.             IF( SYM )THEN
  2814.                JJ = J + ( J - 1 )*LDA
  2815.                AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
  2816.             END IF
  2817.   130    CONTINUE
  2818.       ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN
  2819.          DO 170 J = 1, N
  2820.             IF( UPPER )THEN
  2821.                KK = KL + 1
  2822.                IBEG = MAX( 1, KL + 2 - J )
  2823.                IF( UNIT )THEN
  2824.                   IEND = KL
  2825.                ELSE
  2826.                   IEND = KL + 1
  2827.                END IF
  2828.             ELSE
  2829.                KK = 1
  2830.                IF( UNIT )THEN
  2831.                   IBEG = 2
  2832.                ELSE
  2833.                   IBEG = 1
  2834.                END IF
  2835.                IEND = MIN( KL + 1, 1 + M - J )
  2836.             END IF
  2837.             DO 140 I = 1, IBEG - 1
  2838.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2839.   140       CONTINUE
  2840.             DO 150 I = IBEG, IEND
  2841.                AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
  2842.   150       CONTINUE
  2843.             DO 160 I = IEND + 1, LDA
  2844.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2845.   160       CONTINUE
  2846.             IF( SYM )THEN
  2847.                JJ = KK + ( J - 1 )*LDA
  2848.                AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
  2849.             END IF
  2850.   170    CONTINUE
  2851.       ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN
  2852.          IOFF = 0
  2853.          DO 190 J = 1, N
  2854.             IF( UPPER )THEN
  2855.                IBEG = 1
  2856.                IEND = J
  2857.             ELSE
  2858.                IBEG = J
  2859.                IEND = N
  2860.             END IF
  2861.             DO 180 I = IBEG, IEND
  2862.                IOFF = IOFF + 1
  2863.                AA( IOFF ) = A( I, J )
  2864.                IF( I.EQ.J )THEN
  2865.                   IF( UNIT )
  2866.      $               AA( IOFF ) = ROGUE
  2867.                   IF( SYM )
  2868.      $               AA( IOFF ) = DCMPLX( DBLE( AA( IOFF ) ), RROGUE )
  2869.                END IF
  2870.   180       CONTINUE
  2871.   190    CONTINUE
  2872.       END IF
  2873.       RETURN
  2874. *
  2875. *     End of ZMAKE.
  2876. *
  2877.       END
  2878.       SUBROUTINE ZMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
  2879.      $                  INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
  2880. *
  2881. *  Checks the results of the computational tests.
  2882. *
  2883. *  Auxiliary routine for test program for Level 2 Blas.
  2884. *
  2885. *  -- Written on 10-August-1987.
  2886. *     Richard Hanson, Sandia National Labs.
  2887. *     Jeremy Du Croz, NAG Central Office.
  2888. *
  2889. *     .. Parameters ..
  2890.       COMPLEX*16         ZERO
  2891.       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ) )
  2892.       DOUBLE PRECISION   RZERO, RONE
  2893.       PARAMETER          ( RZERO = 0.0D0, RONE = 1.0D0 )
  2894. *     .. Scalar Arguments ..
  2895.       COMPLEX*16         ALPHA, BETA
  2896.       DOUBLE PRECISION   EPS, ERR
  2897.       INTEGER            INCX, INCY, M, N, NMAX, NOUT
  2898.       LOGICAL            FATAL, MV
  2899.       CHARACTER*1        TRANS
  2900. *     .. Array Arguments ..
  2901.       COMPLEX*16         A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
  2902.       DOUBLE PRECISION   G( * )
  2903. *     .. Local Scalars ..
  2904.       COMPLEX*16         C
  2905.       DOUBLE PRECISION   ERRI
  2906.       INTEGER            I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
  2907.       LOGICAL            CTRAN, TRAN
  2908. *     .. Intrinsic Functions ..
  2909.       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, SQRT
  2910. *     .. Statement Functions ..
  2911.       DOUBLE PRECISION   ABS1
  2912. *     .. Statement Function definitions ..
  2913.       ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) )
  2914. *     .. Executable Statements ..
  2915.       TRAN = TRANS.EQ.'T'
  2916.       CTRAN = TRANS.EQ.'C'
  2917.       IF( TRAN.OR.CTRAN )THEN
  2918.          ML = N
  2919.          NL = M
  2920.       ELSE
  2921.          ML = M
  2922.          NL = N
  2923.       END IF
  2924.       IF( INCX.LT.0 )THEN
  2925.          KX = NL
  2926.          INCXL = -1
  2927.       ELSE
  2928.          KX = 1
  2929.          INCXL = 1
  2930.       END IF
  2931.       IF( INCY.LT.0 )THEN
  2932.          KY = ML
  2933.          INCYL = -1
  2934.       ELSE
  2935.          KY = 1
  2936.          INCYL = 1
  2937.       END IF
  2938. *
  2939. *     Compute expected result in YT using data in A, X and Y.
  2940. *     Compute gauges in G.
  2941. *
  2942.       IY = KY
  2943.       DO 40 I = 1, ML
  2944.          YT( IY ) = ZERO
  2945.          G( IY ) = RZERO
  2946.          JX = KX
  2947.          IF( TRAN )THEN
  2948.             DO 10 J = 1, NL
  2949.                YT( IY ) = YT( IY ) + A( J, I )*X( JX )
  2950.                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
  2951.                JX = JX + INCXL
  2952.    10       CONTINUE
  2953.          ELSE IF( CTRAN )THEN
  2954.             DO 20 J = 1, NL
  2955.                YT( IY ) = YT( IY ) + DCONJG( A( J, I ) )*X( JX )
  2956.                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
  2957.                JX = JX + INCXL
  2958.    20       CONTINUE
  2959.          ELSE
  2960.             DO 30 J = 1, NL
  2961.                YT( IY ) = YT( IY ) + A( I, J )*X( JX )
  2962.                G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) )
  2963.                JX = JX + INCXL
  2964.    30       CONTINUE
  2965.          END IF
  2966.          YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
  2967.          G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) )
  2968.          IY = IY + INCYL
  2969.    40 CONTINUE
  2970. *
  2971. *     Compute the error ratio for this result.
  2972. *
  2973.       ERR = ZERO
  2974.       DO 50 I = 1, ML
  2975.          ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
  2976.          IF( G( I ).NE.RZERO )
  2977.      $      ERRI = ERRI/G( I )
  2978.          ERR = MAX( ERR, ERRI )
  2979.          IF( ERR*SQRT( EPS ).GE.RONE )
  2980.      $      GO TO 60
  2981.    50 CONTINUE
  2982. *     If the loop completes, all results are at least half accurate.
  2983.       GO TO 80
  2984. *
  2985. *     Report fatal error.
  2986. *
  2987.    60 FATAL = .TRUE.
  2988.       WRITE( NOUT, FMT = 9999 )
  2989.       DO 70 I = 1, ML
  2990.          IF( MV )THEN
  2991.             WRITE( NOUT, FMT = 9998 )I, YT( I ),
  2992.      $         YY( 1 + ( I - 1 )*ABS( INCY ) )
  2993.          ELSE
  2994.             WRITE( NOUT, FMT = 9998 )I,
  2995.      $         YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
  2996.          END IF
  2997.    70 CONTINUE
  2998. *
  2999.    80 CONTINUE
  3000.       RETURN
  3001. *
  3002.  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
  3003.      $      'F ACCURATE *******', /'                       EXPECTED RE',
  3004.      $      'SULT                    COMPUTED RESULT' )
  3005.  9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
  3006. *
  3007. *     End of ZMVCH.
  3008. *
  3009.       END
  3010.       LOGICAL FUNCTION LZE( RI, RJ, LR )
  3011. *
  3012. *  Tests if two arrays are identical.
  3013. *
  3014. *  Auxiliary routine for test program for Level 2 Blas.
  3015. *
  3016. *  -- Written on 10-August-1987.
  3017. *     Richard Hanson, Sandia National Labs.
  3018. *     Jeremy Du Croz, NAG Central Office.
  3019. *
  3020. *     .. Scalar Arguments ..
  3021.       INTEGER            LR
  3022. *     .. Array Arguments ..
  3023.       COMPLEX*16         RI( * ), RJ( * )
  3024. *     .. Local Scalars ..
  3025.       INTEGER            I
  3026. *     .. Executable Statements ..
  3027.       DO 10 I = 1, LR
  3028.          IF( RI( I ).NE.RJ( I ) )
  3029.      $      GO TO 20
  3030.    10 CONTINUE
  3031.       LZE = .TRUE.
  3032.       GO TO 30
  3033.    20 CONTINUE
  3034.       LZE = .FALSE.
  3035.    30 RETURN
  3036. *
  3037. *     End of LZE.
  3038. *
  3039.       END
  3040.       LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA )
  3041. *
  3042. *  Tests if selected elements in two arrays are equal.
  3043. *
  3044. *  TYPE is 'GE', 'HE' or 'HP'.
  3045. *
  3046. *  Auxiliary routine for test program for Level 2 Blas.
  3047. *
  3048. *  -- Written on 10-August-1987.
  3049. *     Richard Hanson, Sandia National Labs.
  3050. *     Jeremy Du Croz, NAG Central Office.
  3051. *
  3052. *     .. Scalar Arguments ..
  3053.       INTEGER            LDA, M, N
  3054.       CHARACTER*1        UPLO
  3055.       CHARACTER*2        TYPE
  3056. *     .. Array Arguments ..
  3057.       COMPLEX*16         AA( LDA, * ), AS( LDA, * )
  3058. *     .. Local Scalars ..
  3059.       INTEGER            I, IBEG, IEND, J
  3060.       LOGICAL            UPPER
  3061. *     .. Executable Statements ..
  3062.       UPPER = UPLO.EQ.'U'
  3063.       IF( TYPE.EQ.'GE' )THEN
  3064.          DO 20 J = 1, N
  3065.             DO 10 I = M + 1, LDA
  3066.                IF( AA( I, J ).NE.AS( I, J ) )
  3067.      $            GO TO 70
  3068.    10       CONTINUE
  3069.    20    CONTINUE
  3070.       ELSE IF( TYPE.EQ.'HE' )THEN
  3071.          DO 50 J = 1, N
  3072.             IF( UPPER )THEN
  3073.                IBEG = 1
  3074.                IEND = J
  3075.             ELSE
  3076.                IBEG = J
  3077.                IEND = N
  3078.             END IF
  3079.             DO 30 I = 1, IBEG - 1
  3080.                IF( AA( I, J ).NE.AS( I, J ) )
  3081.      $            GO TO 70
  3082.    30       CONTINUE
  3083.             DO 40 I = IEND + 1, LDA
  3084.                IF( AA( I, J ).NE.AS( I, J ) )
  3085.      $            GO TO 70
  3086.    40       CONTINUE
  3087.    50    CONTINUE
  3088.       END IF
  3089. *
  3090.    60 CONTINUE
  3091.       LZERES = .TRUE.
  3092.       GO TO 80
  3093.    70 CONTINUE
  3094.       LZERES = .FALSE.
  3095.    80 RETURN
  3096. *
  3097. *     End of LZERES.
  3098. *
  3099.       END
  3100.       COMPLEX*16 FUNCTION ZBEG( RESET )
  3101. *
  3102. *  Generates complex numbers as pairs of random numbers uniformly
  3103. *  distributed between -0.5 and 0.5.
  3104. *
  3105. *  Auxiliary routine for test program for Level 2 Blas.
  3106. *
  3107. *  -- Written on 10-August-1987.
  3108. *     Richard Hanson, Sandia National Labs.
  3109. *     Jeremy Du Croz, NAG Central Office.
  3110. *
  3111. *     .. Scalar Arguments ..
  3112.       LOGICAL            RESET
  3113. *     .. Local Scalars ..
  3114.       INTEGER            I, IC, J, MI, MJ
  3115. *     .. Save statement ..
  3116.       SAVE               I, IC, J, MI, MJ
  3117. *     .. Intrinsic Functions ..
  3118.       INTRINSIC          DCMPLX
  3119. *     .. Executable Statements ..
  3120.       IF( RESET )THEN
  3121. *        Initialize local variables.
  3122.          MI = 891
  3123.          MJ = 457
  3124.          I = 7
  3125.          J = 7
  3126.          IC = 0
  3127.          RESET = .FALSE.
  3128.       END IF
  3129. *
  3130. *     The sequence of values of I or J is bounded between 1 and 999.
  3131. *     If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
  3132. *     If initial I or J = 4 or 8, the period will be 25.
  3133. *     If initial I or J = 5, the period will be 10.
  3134. *     IC is used to break up the period by skipping 1 value of I or J
  3135. *     in 6.
  3136. *
  3137.       IC = IC + 1
  3138.    10 I = I*MI
  3139.       J = J*MJ
  3140.       I = I - 1000*( I/1000 )
  3141.       J = J - 1000*( J/1000 )
  3142.       IF( IC.GE.5 )THEN
  3143.          IC = 0
  3144.          GO TO 10
  3145.       END IF
  3146.       ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 )
  3147.       RETURN
  3148. *
  3149. *     End of ZBEG.
  3150. *
  3151.       END
  3152.       DOUBLE PRECISION FUNCTION DDIFF( X, Y )
  3153. *
  3154. *  Auxiliary routine for test program for Level 2 Blas.
  3155. *
  3156. *  -- Written on 10-August-1987.
  3157. *     Richard Hanson, Sandia National Labs.
  3158. *
  3159. *     .. Scalar Arguments ..
  3160.       DOUBLE PRECISION   X, Y
  3161. *     .. Executable Statements ..
  3162.       DDIFF = X - Y
  3163.       RETURN
  3164. *
  3165. *     End of DDIFF.
  3166. *
  3167.       END
  3168.       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  3169. *
  3170. *  Tests whether XERBLA has detected an error when it should.
  3171. *
  3172. *  Auxiliary routine for test program for Level 2 Blas.
  3173. *
  3174. *  -- Written on 10-August-1987.
  3175. *     Richard Hanson, Sandia National Labs.
  3176. *     Jeremy Du Croz, NAG Central Office.
  3177. *
  3178. *     .. Scalar Arguments ..
  3179.       INTEGER            INFOT, NOUT
  3180.       LOGICAL            LERR, OK
  3181.       CHARACTER*6        SRNAMT
  3182. *     .. Executable Statements ..
  3183.       IF( .NOT.LERR )THEN
  3184.          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
  3185.          OK = .FALSE.
  3186.       END IF
  3187.       LERR = .FALSE.
  3188.       RETURN
  3189. *
  3190.  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
  3191.      $      'ETECTED BY ', A6, ' *****' )
  3192. *
  3193. *     End of CHKXER.
  3194. *
  3195.       END
  3196.       SUBROUTINE XERBLA( SRNAME, INFO )
  3197. *
  3198. *  This is a special version of XERBLA to be used only as part of
  3199. *  the test program for testing error exits from the Level 2 BLAS
  3200. *  routines.
  3201. *
  3202. *  XERBLA  is an error handler for the Level 2 BLAS routines.
  3203. *
  3204. *  It is called by the Level 2 BLAS routines if an input parameter is
  3205. *  invalid.
  3206. *
  3207. *  Auxiliary routine for test program for Level 2 Blas.
  3208. *
  3209. *  -- Written on 10-August-1987.
  3210. *     Richard Hanson, Sandia National Labs.
  3211. *     Jeremy Du Croz, NAG Central Office.
  3212. *
  3213. *     .. Scalar Arguments ..
  3214.       INTEGER            INFO
  3215.       CHARACTER*6        SRNAME
  3216. *     .. Scalars in Common ..
  3217.       INTEGER            INFOT, NOUT
  3218.       LOGICAL            LERR, OK
  3219.       CHARACTER*6        SRNAMT
  3220. *     .. Common blocks ..
  3221.       COMMON             /INFOC/INFOT, NOUT, OK, LERR
  3222.       COMMON             /SRNAMC/SRNAMT
  3223. *     .. Executable Statements ..
  3224.       LERR = .TRUE.
  3225.       IF( INFO.NE.INFOT )THEN
  3226.          IF( INFOT.NE.0 )THEN
  3227.             WRITE( NOUT, FMT = 9999 )INFO, INFOT
  3228.          ELSE
  3229.             WRITE( NOUT, FMT = 9997 )INFO
  3230.          END IF
  3231.          OK = .FALSE.
  3232.       END IF
  3233.       IF( SRNAME.NE.SRNAMT )THEN
  3234.          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
  3235.          OK = .FALSE.
  3236.       END IF
  3237.       RETURN
  3238. *
  3239.  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
  3240.      $      ' OF ', I2, ' *******' )
  3241.  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
  3242.      $      'AD OF ', A6, ' *******' )
  3243.  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
  3244.      $      ' *******' )
  3245. *
  3246. *     End of XERBLA
  3247. *
  3248.       END
  3249.  
  3250.